diff options
83 files changed, 0 insertions, 41651 deletions
diff --git a/unix/Makefile.in b/unix/Makefile.in deleted file mode 100644 index 5a791d2..0000000 --- a/unix/Makefile.in +++ /dev/null @@ -1,1320 +0,0 @@ -# -# This file is a Makefile for Tcl. 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. -# -# RCS: @(#) $Id: Makefile.in,v 1.63.2.2 2000/08/07 22:04:23 hobbs Exp $ - -VERSION = @TCL_VERSION@ - -#---------------------------------------------------------------- -# Things you can change to personalize the Makefile for your own -# site (you can make these changes in either Makefile.in or -# Makefile, but changes to Makefile will get lost if you re-run -# the configuration script). -#---------------------------------------------------------------- - -# Default top-level directories in which to install architecture- -# specific files (exec_prefix) and machine-independent files such -# as scripts (prefix). The values specified here may be overridden -# at configure-time with the --exec-prefix and --prefix options -# to the "configure" script. The *dir vars are standard configure -# substitutions that are based off prefix and exec_prefix. - -prefix = @prefix@ -exec_prefix = @exec_prefix@ -bindir = @bindir@ -libdir = @libdir@ -includedir = @includedir@ -mandir = @mandir@ - -# The following definition can be set to non-null for special systems -# like AFS with replication. It allows the pathnames used for installation -# to be different than those used for actually reference files at -# run-time. INSTALL_ROOT is prepended to $prefix and $exec_prefix -# when installing files. -INSTALL_ROOT = - -# Path for the platform independent Tcl scripting libraries: -TCL_LIBRARY = $(prefix)/lib/tcl$(VERSION) - -# Path to use at runtime to refer to LIB_INSTALL_DIR: -LIB_RUNTIME_DIR = $(libdir) - -# Directory in which to install the program tclsh: -BIN_INSTALL_DIR = $(INSTALL_ROOT)$(bindir) - -# Directory in which to install libtcl.so or libtcl.a: -LIB_INSTALL_DIR = $(INSTALL_ROOT)$(libdir) - -# Path name to use when installing library scripts. -SCRIPT_INSTALL_DIR = $(INSTALL_ROOT)$(TCL_LIBRARY) - -# Directory in which to install the include file tcl.h: -INCLUDE_INSTALL_DIR = $(INSTALL_ROOT)$(includedir) - -# Top-level directory in which to install manual entries: -MAN_INSTALL_DIR = $(INSTALL_ROOT)$(mandir) - -# Directory in which to install manual entry for tclsh: -MAN1_INSTALL_DIR = $(MAN_INSTALL_DIR)/man1 - -# Directory in which to install manual entries for Tcl's C library -# procedures: -MAN3_INSTALL_DIR = $(MAN_INSTALL_DIR)/man3 - -# Directory in which to install manual entries for the built-in -# Tcl commands: -MANN_INSTALL_DIR = $(MAN_INSTALL_DIR)/mann - -# Package search path. -TCL_PACKAGE_PATH = @TCL_PACKAGE_PATH@ - -# Libraries built with optimization switches have this additional extension -TCL_DBGX = @TCL_DBGX@ - -# warning flags -CFLAGS_WARNING = @CFLAGS_WARNING@ - -# The default switches for optimization or debugging -CFLAGS_DEBUG = @CFLAGS_DEBUG@ -CFLAGS_OPTIMIZE = @CFLAGS_OPTIMIZE@ - -# To change the compiler switches, for example to change from optimization to -# debugging symbols, change the following line: -#CFLAGS = $(CFLAGS_DEBUG) -#CFLAGS = $(CFLAGS_OPTIMIZE) -#CFLAGS = $(CFLAGS_DEBUG) $(CFLAGS_OPTIMIZE) -CFLAGS = @CFLAGS@ - -# To disable ANSI-C procedure prototypes reverse the comment characters -# on the following lines: -PROTO_FLAGS = -#PROTO_FLAGS = -DNO_PROTOTYPE - -# Mathematical functions like sin and atan2 are enabled for expressions -# by default. To disable them, reverse the comment characters on the -# following pairs of lines: -MATH_FLAGS = -#MATH_FLAGS = -DTCL_NO_MATH -MATH_LIBS = @MATH_LIBS@ -#MATH_LIBS = - -# If you use the setenv, putenv, or unsetenv procedures to modify -# environment variables in your application and you'd like those -# modifications to appear in the "env" Tcl variable, switch the -# comments on the two lines below so that Tcl provides these -# procedures instead of your standard C library. - -ENV_FLAGS = -#ENV_FLAGS = -DTclSetEnv=setenv -DTcl_PutEnv=putenv -DTclUnsetEnv=unsetenv - -# To compile for non-UNIX systems (so that only the non-UNIX-specific -# commands are available), reverse the comment characters on the -# following pairs of lines. In addition, you'll have to provide your -# own replacement for the "panic" procedure (see panic.c for what -# the current one does). -GENERIC_FLAGS = -#GENERIC_FLAGS = -DTCL_GENERIC_ONLY -UNIX_OBJS = tclMtherr.o tclUnixChan.o tclUnixEvent.o tclUnixFCmd.o \ - tclUnixFile.o tclUnixPipe.o tclUnixSock.o \ - tclUnixTime.o tclUnixInit.o tclUnixThrd.o -#UNIX_OBJS = -NOTIFY_OBJS = tclUnixNotfy.o -#NOTIFY_OBJS = - -# To enable memory debugging reverse the comment characters on the following -# lines. Warning: if you enable memory debugging, you must do it -# *everywhere*, including all the code that calls Tcl, and you must use -# ckalloc and ckfree everywhere instead of malloc and free. -MEM_DEBUG_FLAGS = -#MEM_DEBUG_FLAGS = -DTCL_MEM_DEBUG - -# To enable support for stubs in Tcl. -STUB_LIB_FILE = @STUB_LIB_FILE@ - -TCL_STUB_LIB_FILE = @TCL_STUB_LIB_FILE@ -#TCL_STUB_LIB_FILE = libtclstub.a - -TCL_STUB_LIB_FLAG = @TCL_STUB_LIB_FLAG@ -#TCL_STUB_LIB_FLAG = -ltclstub - -# To enable compilation debugging reverse the comment characters on -# one of the following lines. -COMPILE_DEBUG_FLAGS = -#COMPILE_DEBUG_FLAGS = -DTCL_COMPILE_STATS -#COMPILE_DEBUG_FLAGS = -DTCL_COMPILE_DEBUG -DTCL_COMPILE_STATS - -# To compile without backward compatibility and deprecated code -# uncomment the following -NO_DEPRECATED_FLAGS = -#NO_DEPRECATED_FLAGS = -DTCL_NO_DEPRECATED - -# Some versions of make, like SGI's, use the following variable to -# determine which shell to use for executing commands: -SHELL = /bin/sh - -# Tcl used to let the configure script choose which program to use -# for installing, but there are just too many different versions of -# "install" around; better to use the install-sh script that comes -# with the distribution, which is slower but guaranteed to work. - -INSTALL = @srcdir@/install-sh -c -INSTALL_PROGRAM = ${INSTALL} -INSTALL_DATA = ${INSTALL} -m 644 - -# The following specifies which Tcl executable to use for make targets -# below. This can generally be 'tclsh', meaning all targets will work -# once we have created the initial executable, but in some cases you -# may want to use a target without having made tclsh on these sources -# (like for make genstubs) -TCL_EXE = tclsh - -# The symbols below provide support for dynamic loading and shared -# libraries. See configure.in for a description of what the -# symbols mean. The values of the symbols are normally set by the -# configure script. You shouldn't normally need to modify any of -# these definitions by hand. - -STLIB_LD = @STLIB_LD@ -SHLIB_LD = @SHLIB_LD@ -SHLIB_CFLAGS = @SHLIB_CFLAGS@ - -SHLIB_SUFFIX = @SHLIB_SUFFIX@ -#SHLIB_SUFFIX = - -DLTEST_TARGETS = dltest/pkg5${SHLIB_SUFFIX} dltest/Makefile - -# The following symbol is defined to "$(DLTEST_TARGETS)" if dynamic -# loading is available; this causes everything in the "dltest" -# subdirectory to be built when making "tcltest. If dynamic loading -# isn't available, configure defines this symbol to an empty string, -# in which case the shared libraries aren't built. -BUILD_DLTEST = @BUILD_DLTEST@ -#BUILD_DLTEST = - -TCL_LIB_FILE = @TCL_LIB_FILE@ -#TCL_LIB_FILE = libtcl.a - -TCL_LIB_FLAG = @TCL_LIB_FLAG@ -#TCL_LIB_FLAG = -ltcl - -TCL_EXP_FILE = @TCL_EXP_FILE@ -TCL_BUILD_EXP_FILE = @TCL_BUILD_EXP_FILE@ - -#---------------------------------------------------------------- -# The information below is modified by the configure script when -# Makefile is generated from Makefile.in. You shouldn't normally -# modify any of this stuff by hand. -#---------------------------------------------------------------- - -COMPAT_OBJS = @LIBOBJS@ - -AC_FLAGS = @EXTRA_CFLAGS@ @DEFS@ -RANLIB = @RANLIB@ -SRC_DIR = @srcdir@ -TOP_DIR = @srcdir@/.. -GENERIC_DIR = $(TOP_DIR)/generic -COMPAT_DIR = $(TOP_DIR)/compat -TOOL_DIR = $(TOP_DIR)/tools -UNIX_DIR = $(TOP_DIR)/unix -# Must be absolute because of the cd dltest $(DLTEST_DIR)/configure below. -DLTEST_DIR = @TCL_SRC_DIR@/unix/dltest -# Must be absolute to so the corresponding tcltest's tcl_library is absolute. -TCL_BUILDTIME_LIBRARY = @TCL_SRC_DIR@/library - -#CC = purify -best-effort @CC@ -CC = @CC@ - -#---------------------------------------------------------------- -# The information below should be usable as is. The configure -# script won't modify it and you shouldn't need to modify it -# either. -#---------------------------------------------------------------- - - -CC_SWITCHES = ${CFLAGS} ${CFLAGS_WARNING} ${SHLIB_CFLAGS} \ --I${GENERIC_DIR} -I${SRC_DIR} \ -${AC_FLAGS} ${MATH_FLAGS} ${GENERIC_FLAGS} ${PROTO_FLAGS} ${MEM_DEBUG_FLAGS} \ -${COMPILE_DEBUG_FLAGS} ${NO_DEPRECATED_FLAGS} ${ENV_FLAGS} \ --DTCL_SHLIB_EXT=\"${SHLIB_SUFFIX}\" - -STUB_CC_SWITCHES = ${CFLAGS} ${CFLAGS_WARNING} ${SHLIB_CFLAGS} \ --I${GENERIC_DIR} -I${SRC_DIR} \ -${AC_FLAGS} ${MATH_FLAGS} ${GENERIC_FLAGS} ${PROTO_FLAGS} ${MEM_DEBUG_FLAGS} \ -${COMPILE_DEBUG_FLAGS} ${ENV_FLAGS} -DTCL_SHLIB_EXT=\"${SHLIB_SUFFIX}\" - -LIBS = @DL_LIBS@ @LIBS@ $(MATH_LIBS) -lc - -DEPEND_SWITCHES = ${CFLAGS} -I${GENERIC_DIR} -I${SRC_DIR} \ -${AC_FLAGS} ${MATH_FLAGS} \ -${GENERIC_FLAGS} ${PROTO_FLAGS} ${MEM_DEBUG_FLAGS} \ --DTCL_SHLIB_EXT=\"${SHLIB_SUFFIX}\" - -TCLSH_OBJS = tclAppInit.o - -TCLTEST_OBJS = tclTestInit.o tclTest.o tclTestObj.o tclTestProcBodyObj.o \ - tclThreadTest.o tclUnixTest.o - -XTTEST_OBJS = xtTestInit.o tclTest.o tclTestObj.o tclTestProcBodyObj.o \ - tclThreadTest.o tclUnixTest.o tclXtNotify.o tclXtTest.o - -GENERIC_OBJS = regcomp.o regexec.o regfree.o regerror.o tclAlloc.o \ - tclAsync.o tclBasic.o tclBinary.o \ - tclCkalloc.o tclClock.o tclCmdAH.o tclCmdIL.o tclCmdMZ.o \ - tclCompCmds.o tclCompExpr.o tclCompile.o tclDate.o tclEncoding.o \ - tclEnv.o tclEvent.o tclExecute.o tclFCmd.o tclFileName.o tclGet.o \ - tclHash.o tclHistory.o tclIndexObj.o tclInterp.o tclIO.o tclIOCmd.o \ - tclIOGT.o tclIOSock.o tclIOUtil.o tclLink.o tclListObj.o \ - tclLiteral.o tclLoad.o tclMain.o tclNamesp.o tclNotify.o \ - tclObj.o tclPanic.o tclParse.o tclParseExpr.o tclPipe.o \ - tclPkg.o tclPosixStr.o tclPreserve.o tclProc.o tclRegexp.o \ - tclResolve.o tclResult.o tclScan.o tclStringObj.o tclThread.o \ - tclStubInit.o tclStubLib.o tclTimer.o tclUtf.o tclUtil.o tclVar.o - -STUB_LIB_OBJS = tclStubLib.o ${COMPAT_OBJS} - -OBJS = ${GENERIC_OBJS} ${UNIX_OBJS} ${NOTIFY_OBJS} ${COMPAT_OBJS} @DL_OBJS@ - -TCL_DECLS = \ - $(GENERIC_DIR)/tcl.decls \ - $(GENERIC_DIR)/tclInt.decls - -GENERIC_HDRS = \ - $(GENERIC_DIR)/tcl.h \ - $(GENERIC_DIR)/tclDecls.h \ - $(GENERIC_DIR)/tclInt.h \ - $(GENERIC_DIR)/tclIntDecls.h \ - $(GENERIC_DIR)/tclIntPlatDecls.h \ - $(GENERIC_DIR)/tclPatch.h \ - $(GENERIC_DIR)/tclPlatDecls.h \ - $(GENERIC_DIR)/tclPort.h \ - $(GENERIC_DIR)/tclRegexp.h - -GENERIC_SRCS = \ - $(GENERIC_DIR)/regcomp.c \ - $(GENERIC_DIR)/regexec.c \ - $(GENERIC_DIR)/regfree.c \ - $(GENERIC_DIR)/regerror.c \ - $(GENERIC_DIR)/tclAlloc.c \ - $(GENERIC_DIR)/tclAsync.c \ - $(GENERIC_DIR)/tclBasic.c \ - $(GENERIC_DIR)/tclBinary.c \ - $(GENERIC_DIR)/tclCkalloc.c \ - $(GENERIC_DIR)/tclClock.c \ - $(GENERIC_DIR)/tclCmdAH.c \ - $(GENERIC_DIR)/tclCmdIL.c \ - $(GENERIC_DIR)/tclCmdMZ.c \ - $(GENERIC_DIR)/tclCompCmds.c \ - $(GENERIC_DIR)/tclCompExpr.c \ - $(GENERIC_DIR)/tclCompile.c \ - $(GENERIC_DIR)/tclDate.c \ - $(GENERIC_DIR)/tclEncoding.c \ - $(GENERIC_DIR)/tclEnv.c \ - $(GENERIC_DIR)/tclEvent.c \ - $(GENERIC_DIR)/tclExecute.c \ - $(GENERIC_DIR)/tclFCmd.c \ - $(GENERIC_DIR)/tclFileName.c \ - $(GENERIC_DIR)/tclGet.c \ - $(GENERIC_DIR)/tclHash.c \ - $(GENERIC_DIR)/tclHistory.c \ - $(GENERIC_DIR)/tclIndexObj.c \ - $(GENERIC_DIR)/tclInterp.c \ - $(GENERIC_DIR)/tclIO.c \ - $(GENERIC_DIR)/tclIOCmd.c \ - $(GENERIC_DIR)/tclIOGT.c \ - $(GENERIC_DIR)/tclIOSock.c \ - $(GENERIC_DIR)/tclIOUtil.c \ - $(GENERIC_DIR)/tclLink.c \ - $(GENERIC_DIR)/tclListObj.c \ - $(GENERIC_DIR)/tclLiteral.c \ - $(GENERIC_DIR)/tclLoad.c \ - $(GENERIC_DIR)/tclMain.c \ - $(GENERIC_DIR)/tclNamesp.c \ - $(GENERIC_DIR)/tclNotify.c \ - $(GENERIC_DIR)/tclObj.c \ - $(GENERIC_DIR)/tclParse.c \ - $(GENERIC_DIR)/tclParseExpr.c \ - $(GENERIC_DIR)/tclPipe.c \ - $(GENERIC_DIR)/tclPkg.c \ - $(GENERIC_DIR)/tclPosixStr.c \ - $(GENERIC_DIR)/tclPreserve.c \ - $(GENERIC_DIR)/tclProc.c \ - $(GENERIC_DIR)/tclRegexp.c \ - $(GENERIC_DIR)/tclResolve.c \ - $(GENERIC_DIR)/tclResult.c \ - $(GENERIC_DIR)/tclScan.c \ - $(GENERIC_DIR)/tclStubInit.c \ - $(GENERIC_DIR)/tclStubLib.c \ - $(GENERIC_DIR)/tclStringObj.c \ - $(GENERIC_DIR)/tclTest.c \ - $(GENERIC_DIR)/tclTestObj.c \ - $(GENERIC_DIR)/tclTestProcBodyObj.c \ - $(GENERIC_DIR)/tclThread.c \ - $(GENERIC_DIR)/tclTimer.c \ - $(GENERIC_DIR)/tclUtil.c \ - $(GENERIC_DIR)/tclVar.c - -STUB_SRCS = \ - $(GENERIC_DIR)/tclStubLib.c - -UNIX_HDRS = \ - $(UNIX_DIR)/tclUnixPort.h - -UNIX_SRCS = \ - $(UNIX_DIR)/tclAppInit.c \ - $(UNIX_DIR)/tclMtherr.c \ - $(UNIX_DIR)/tclUnixChan.c \ - $(UNIX_DIR)/tclUnixEvent.c \ - $(UNIX_DIR)/tclUnixFCmd.c \ - $(UNIX_DIR)/tclUnixFile.c \ - $(UNIX_DIR)/tclUnixNotfy.c \ - $(UNIX_DIR)/tclUnixPipe.c \ - $(UNIX_DIR)/tclUnixSock.c \ - $(UNIX_DIR)/tclUnixTest.c \ - $(UNIX_DIR)/tclUnixThrd.c \ - $(UNIX_DIR)/tclUnixTime.c \ - $(UNIX_DIR)/tclUnixInit.c - -DL_SRCS = \ - $(UNIX_DIR)/tclLoadAix.c \ - $(UNIX_DIR)/tclLoadAout.c \ - $(UNIX_DIR)/tclLoadDl.c \ - $(UNIX_DIR)/tclLoadDl2.c \ - $(UNIX_DIR)/tclLoadDld.c \ - $(UNIX_DIR)/tclLoadDyld.c \ - $(GENERIC_DIR)/tclLoadNone.c \ - $(UNIX_DIR)/tclLoadOSF.c \ - $(UNIX_DIR)/tclLoadShl.c - -# Note: don't include DL_SRCS in SRCS: most of those files won't -# compile on the current machine, and they will cause problems for -# things like "make depend". - -SRCS = $(GENERIC_SRCS) $(UNIX_SRCS) $(STUB_SRCS) - -all: binaries libraries doc - -binaries: ${TCL_LIB_FILE} $(TCL_STUB_LIB_FILE) $(TCL_BUILD_EXP_FILE) tclsh - -libraries: - -doc: - -# The following target is configured by autoconf to generate either -# a shared library or non-shared library for Tcl. -${TCL_LIB_FILE}: ${OBJS} ${STUB_LIB_FILE} - rm -f ${TCL_LIB_FILE} - @MAKE_LIB@ - $(RANLIB) ${TCL_LIB_FILE} - -${STUB_LIB_FILE}: ${STUB_LIB_OBJS} - rm -f ${STUB_LIB_FILE} - @MAKE_STUB_LIB@ - $(RANLIB) ${STUB_LIB_FILE} - -# Make target which outputs the list of the .o contained in the Tcl lib -# usefull to build a single big shared library containing Tcl and other -# extensions. used for the Tcl Plugin. -- dl -# The dependency on OBJS is not there because we just want the list -# of objects here, not actually building them -tclLibObjs: - @echo ${OBJS} -# This targets actually build the objects needed for the lib in the above -# case -objs: ${OBJS} - - -tclsh: ${TCLSH_OBJS} ${TCL_LIB_FILE} - ${CC} @LDFLAGS@ ${TCLSH_OBJS} @TCL_BUILD_LIB_SPEC@ ${LIBS} \ - @TCL_LD_SEARCH_FLAGS@ -o tclsh - -tcltest: ${TCLTEST_OBJS} ${TCL_LIB_FILE} ${BUILD_DLTEST} - ${CC} @LDFLAGS@ ${TCLTEST_OBJS} @TCL_BUILD_LIB_SPEC@ ${LIBS} \ - @TCL_LD_SEARCH_FLAGS@ -o tcltest - - -# Note, in the target below TCL_LIBRARY needs to be set or else -# "make test" won't work in the case where the compilation directory -# isn't the same as the source directory. - -test: tcltest - LD_LIBRARY_PATH=`pwd`:${LD_LIBRARY_PATH}; export LD_LIBRARY_PATH; \ - LIBPATH=`pwd`:${LIBPATH}; export LIBPATH; \ - SHLIB_PATH=`pwd`:${SHLIB_PATH}; export SHLIB_PATH; \ - TCL_LIBRARY="${TCL_BUILDTIME_LIBRARY}"; export TCL_LIBRARY; \ - ./tcltest $(TOP_DIR)/tests/all.tcl $(TCLTESTARGS) - -# Useful target to launch a built tcltest with the proper path,... -runtest: tcltest - LD_LIBRARY_PATH=`pwd`:${LD_LIBRARY_PATH}; export LD_LIBRARY_PATH; \ - LIBPATH=`pwd`:${LIBPATH}; export LIBPATH; \ - SHLIB_PATH=`pwd`:${SHLIB_PATH}; export SHLIB_PATH; \ - TCL_LIBRARY="${TCL_BUILDTIME_LIBRARY}"; export TCL_LIBRARY; \ - ./tcltest - -# The following target outputs the name of the top-level source directory -# for Tcl (it is used by Tk's configure script, for example). The -# .NO_PARALLEL line is needed to avoid problems under Sun's "pmake". -# Note: this target is now obsolete (use the autoconf variable -# TCL_SRC_DIR from tclConfig.sh instead). - -.NO_PARALLEL: topDirName -topDirName: - @cd $(TOP_DIR); pwd - -# The following target generates the file generic/tclDate.c -# from the yacc grammar found in generic/tclGetDate.y. This is -# only run by hand as yacc is not available in all environments. -# The name of the .c file is different than the name of the .y file -# so that make doesn't try to automatically regenerate the .c file. - -gendate: - yacc -l $(GENERIC_DIR)/tclGetDate.y - sed -e 's/yy/TclDate/g' -e '/^#include <values.h>/d' \ - -e 's?SCCSID?RCS: @(#) $$Id: Makefile.in,v 1.63.2.2 2000/08/07 22:04:23 hobbs Exp $$?' \ - -e '/#ifdef __STDC__/,/#endif/d' -e '/TclDateerrlab:/d' \ - -e '/TclDatenewstate:/d' -e '/#pragma/d' \ - -e '/#include <inttypes.h>/d' -e 's/const /CONST /g' \ - <y.tab.c >$(GENERIC_DIR)/tclDate.c - rm y.tab.c - -# The following targets generate the shared libraries in dltest that -# are used for testing; they are included as part of the "tcltest" -# target (via the BUILD_DLTEST variable) if dynamic loading is supported -# on this platform. The ".." environment variable stuff is needed -# because on some platforms tclsh scripts will be executed as part of -# building the shared libraries, and they need to be able to use the -# uninstalled tclsh that is present in this directory. The "make tclsh" -# command is needed for the same reason (must make sure that it exists). - -dltest/pkg5${SHLIB_SUFFIX}: dltest/Makefile - if test ! -f tclsh; then $(MAKE) tclsh; else true; fi - cd dltest; PATH=..:${PATH} TCL_LIBRARY=../../library $(MAKE) - -dltest/Makefile: $(DLTEST_DIR)/configure $(DLTEST_DIR)/Makefile.in tclConfig.sh - if test ! -d dltest; then mkdir dltest; else true; fi - cd dltest; if test -f configure; then ./configure; else \ - $(DLTEST_DIR)/configure; fi - -install: install-binaries install-libraries install-doc - -install-strip: - $(MAKE) install INSTALL_PROGRAM="$(INSTALL_PROGRAM) -s" - -# Note: before running ranlib below, must cd to target directory because -# some ranlibs write to current directory, and this might not always be -# possible (e.g. if installing as root). - -install-binaries: binaries - @for i in $(LIB_INSTALL_DIR) $(BIN_INSTALL_DIR) ; \ - do \ - if [ ! -d $$i ] ; then \ - echo "Making directory $$i"; \ - mkdir -p $$i; \ - chmod 755 $$i; \ - else true; \ - fi; \ - done; - @if test ! -x $(SRC_DIR)/install-sh; then \ - chmod +x $(SRC_DIR)/install-sh; \ - fi - @echo "Installing $(TCL_LIB_FILE) to $(LIB_INSTALL_DIR)/" - @$(INSTALL_DATA) $(TCL_LIB_FILE) $(LIB_INSTALL_DIR)/$(TCL_LIB_FILE) - @(cd $(LIB_INSTALL_DIR); $(RANLIB) $(TCL_LIB_FILE)) - @chmod 555 $(LIB_INSTALL_DIR)/$(TCL_LIB_FILE) - @if test "$(TCL_BUILD_EXP_FILE)" != ""; then \ - echo "Installing $(TCL_EXP_FILE) to $(LIB_INSTALL_DIR)/"; \ - $(INSTALL_DATA) $(TCL_BUILD_EXP_FILE) \ - $(LIB_INSTALL_DIR)/$(TCL_EXP_FILE); \ - fi - @echo "Installing tclsh as $(BIN_INSTALL_DIR)/tclsh$(VERSION)" - @$(INSTALL_PROGRAM) tclsh $(BIN_INSTALL_DIR)/tclsh$(VERSION) - @echo "Installing tclConfig.sh to $(LIB_INSTALL_DIR)/" - @$(INSTALL_DATA) tclConfig.sh $(LIB_INSTALL_DIR)/tclConfig.sh - @if test "$(TCL_STUB_LIB_FILE)" != "" ; then \ - echo "Installing $(TCL_STUB_LIB_FILE) to $(LIB_INSTALL_DIR)/"; \ - $(INSTALL_DATA) $(STUB_LIB_FILE) \ - $(LIB_INSTALL_DIR)/$(TCL_STUB_LIB_FILE); \ - fi - -install-libraries: libraries - @for i in $(INCLUDE_INSTALL_DIR) $(SCRIPT_INSTALL_DIR); \ - do \ - if [ ! -d $$i ] ; then \ - echo "Making directory $$i"; \ - mkdir -p $$i; \ - chmod 755 $$i; \ - else true; \ - fi; \ - done; - @for i in http2.3 http1.0 opt0.4 encoding msgcat1.0 tcltest1.0; \ - do \ - if [ ! -d $(SCRIPT_INSTALL_DIR)/$$i ] ; then \ - echo "Making directory $(SCRIPT_INSTALL_DIR)/$$i"; \ - mkdir -p $(SCRIPT_INSTALL_DIR)/$$i; \ - chmod 755 $(SCRIPT_INSTALL_DIR)/$$i; \ - else true; \ - fi; \ - done; - @if test ! -x $(SRC_DIR)/install-sh; then \ - chmod +x $(SRC_DIR)/install-sh; \ - fi - @echo "Installing header files"; - @for i in $(GENERIC_DIR)/tcl.h $(GENERIC_DIR)/tclDecls.h ; \ - do \ - $(INSTALL_DATA) $$i $(INCLUDE_INSTALL_DIR); \ - done; - @echo "Installing library files to $(SCRIPT_INSTALL_DIR)"; - @for i in $(TOP_DIR)/library/*.tcl $(TOP_DIR)/library/tclIndex $(UNIX_DIR)/tclAppInit.c $(UNIX_DIR)/ldAix; \ - do \ - $(INSTALL_DATA) $$i $(SCRIPT_INSTALL_DIR); \ - done; - @for i in http2.3 http1.0 opt0.4 msgcat1.0 tcltest1.0; \ - do \ - echo "Installing library $$i directory"; \ - for j in $(TOP_DIR)/library/$$i/*.tcl ; \ - do \ - $(INSTALL_DATA) $$j $(SCRIPT_INSTALL_DIR)/$$i; \ - done; \ - done; - @echo "Installing library encoding directory"; - @for i in $(TOP_DIR)/library/encoding/*.enc ; do \ - $(INSTALL_DATA) $$i $(SCRIPT_INSTALL_DIR)/encoding; \ - done; - -install-doc: doc - @if test ! -x $(UNIX_DIR)/mkLinks; then \ - chmod +x $(UNIX_DIR)/mkLinks; \ - fi - @for i in $(MAN_INSTALL_DIR) $(MAN1_INSTALL_DIR) $(MAN3_INSTALL_DIR) $(MANN_INSTALL_DIR) ; \ - do \ - if [ ! -d $$i ] ; then \ - echo "Making directory $$i"; \ - mkdir -p $$i; \ - chmod 755 $$i; \ - else true; \ - fi; \ - done; - @echo "Installing top-level (.1) docs"; - @cd $(TOP_DIR)/doc; for i in *.1; \ - do \ - rm -f $(MAN1_INSTALL_DIR)/$$i; \ - sed -e '/man\.macros/r man.macros' -e '/man\.macros/d' \ - $$i > $(MAN1_INSTALL_DIR)/$$i; \ - chmod 444 $(MAN1_INSTALL_DIR)/$$i; \ - done; - @echo "Cross-linking top-level (.1) docs"; - @$(UNIX_DIR)/mkLinks $(MAN1_INSTALL_DIR) - @echo "Installing C API (.3) docs"; - @cd $(TOP_DIR)/doc; for i in *.3; \ - do \ - rm -f $(MAN3_INSTALL_DIR)/$$i; \ - sed -e '/man\.macros/r man.macros' -e '/man\.macros/d' \ - $$i > $(MAN3_INSTALL_DIR)/$$i; \ - chmod 444 $(MAN3_INSTALL_DIR)/$$i; \ - done; - @echo "Cross-linking C API (.3) docs"; - @$(UNIX_DIR)/mkLinks $(MAN3_INSTALL_DIR) - @echo "Installing command (.n) docs"; - @cd $(TOP_DIR)/doc; for i in *.n; \ - do \ - rm -f $(MANN_INSTALL_DIR)/$$i; \ - sed -e '/man\.macros/r man.macros' -e '/man\.macros/d' \ - $$i > $(MANN_INSTALL_DIR)/$$i; \ - chmod 444 $(MANN_INSTALL_DIR)/$$i; \ - done; - @echo "Cross-linking command (.n) docs"; - @$(UNIX_DIR)/mkLinks $(MANN_INSTALL_DIR) - -Makefile: $(UNIX_DIR)/Makefile.in - $(SHELL) config.status - -clean: - rm -f *.a *.o libtcl* core errs *~ \#* TAGS *.E a.out \ - errors tclsh tcltest lib.exp - if test -f dltest/Makefile; then cd dltest; $(MAKE) clean; fi - -distclean: clean - rm -rf Makefile config.status config.cache config.log tclConfig.sh \ - $(PACKAGE).* prototype - if test -f dltest/Makefile; then cd dltest; $(MAKE) distclean; fi - -depend: - makedepend -- $(DEPEND_SWITCHES) -- $(SRCS) - -bp: $(UNIX_DIR)/bp.c - $(CC) $(CC_SWITCHES) $(UNIX_DIR)/bp.c -o bp - -# Test binaries. The rules for tclTestInit.o and xtTestInit.o are -# complicated because they are compiled from tclAppInit.c. Can't use -# the "-o" option because this doesn't work on some strange compilers -# (e.g. UnixWare). - -tclTestInit.o: $(UNIX_DIR)/tclAppInit.c - @if test -f tclAppInit.o ; then \ - rm -f tclAppInit.sav; \ - mv tclAppInit.o tclAppInit.sav; \ - fi; - $(CC) -c $(CC_SWITCHES) \ - -DTCL_BUILDTIME_LIBRARY="\"${TCL_BUILDTIME_LIBRARY}\"" \ - -DTCL_TEST $(UNIX_DIR)/tclAppInit.c - rm -f tclTestInit.o - mv tclAppInit.o tclTestInit.o - @if test -f tclAppInit.sav ; then \ - mv tclAppInit.sav tclAppInit.o; \ - fi; - -xtTestInit.o: $(UNIX_DIR)/tclAppInit.c - @if test -f tclAppInit.o ; then \ - rm -f tclAppInit.sav; \ - mv tclAppInit.o tclAppInit.sav; \ - fi; - $(CC) -c $(CC_SWITCHES) \ - -DTCL_BUILDTIME_LIBRARY="\"${TCL_BUILDTIME_LIBRARY}\"" \ - -DTCL_TEST -DTCL_XT_TEST $(UNIX_DIR)/tclAppInit.c - rm -f xtTestInit.o - mv tclAppInit.o xtTestInit.o - @if test -f tclAppInit.sav ; then \ - mv tclAppInit.sav tclAppInit.o; \ - fi; - -# Object files used on all Unix systems: - -REGHDRS=$(GENERIC_DIR)/regex.h $(GENERIC_DIR)/regguts.h \ - $(GENERIC_DIR)/regcustom.h -regcomp.o: $(REGHDRS) $(GENERIC_DIR)/regcomp.c $(GENERIC_DIR)/regc_lex.c \ - $(GENERIC_DIR)/regc_color.c $(GENERIC_DIR)/regc_locale.c \ - $(GENERIC_DIR)/regc_nfa.c $(GENERIC_DIR)/regc_cvec.c - $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/regcomp.c - -regexec.o: $(REGHDRS) $(GENERIC_DIR)/regexec.c $(GENERIC_DIR)/rege_dfa.c - $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/regexec.c - -regfree.o: $(REGHDRS) $(GENERIC_DIR)/regfree.c - $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/regfree.c - -regerror.o: $(REGHDRS) $(GENERIC_DIR)/regerrs.h $(GENERIC_DIR)/regerror.c - $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/regerror.c - -tclAppInit.o: $(UNIX_DIR)/tclAppInit.c - $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclAppInit.c - -# On unix we want to use the normal malloc/free implementation, so we -# specifically set the USE_TCLALLOC flag. - -tclAlloc.o: $(GENERIC_DIR)/tclAlloc.c - $(CC) -c $(CC_SWITCHES) -DUSE_TCLALLOC=0 $(GENERIC_DIR)/tclAlloc.c - -tclAsync.o: $(GENERIC_DIR)/tclAsync.c - $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclAsync.c - -tclBasic.o: $(GENERIC_DIR)/tclBasic.c - $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclBasic.c - -tclBinary.o: $(GENERIC_DIR)/tclBinary.c - $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclBinary.c - -tclCkalloc.o: $(GENERIC_DIR)/tclCkalloc.c - $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclCkalloc.c - -tclClock.o: $(GENERIC_DIR)/tclClock.c - $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclClock.c - -tclCmdAH.o: $(GENERIC_DIR)/tclCmdAH.c - $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclCmdAH.c - -tclCmdIL.o: $(GENERIC_DIR)/tclCmdIL.c - $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclCmdIL.c - -tclCmdMZ.o: $(GENERIC_DIR)/tclCmdMZ.c - $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclCmdMZ.c - -tclDate.o: $(GENERIC_DIR)/tclDate.c - $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclDate.c - -tclCompCmds.o: $(GENERIC_DIR)/tclCompCmds.c - $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclCompCmds.c - -tclCompExpr.o: $(GENERIC_DIR)/tclCompExpr.c - $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclCompExpr.c - -tclCompile.o: $(GENERIC_DIR)/tclCompile.c - $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclCompile.c - -tclEncoding.o: $(GENERIC_DIR)/tclEncoding.c - $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclEncoding.c - -tclEnv.o: $(GENERIC_DIR)/tclEnv.c - $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclEnv.c - -tclEvent.o: $(GENERIC_DIR)/tclEvent.c - $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclEvent.c - -tclExecute.o: $(GENERIC_DIR)/tclExecute.c - $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclExecute.c - -tclFCmd.o: $(GENERIC_DIR)/tclFCmd.c - $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclFCmd.c - -tclFileName.o: $(GENERIC_DIR)/tclFileName.c - $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclFileName.c - -tclGet.o: $(GENERIC_DIR)/tclGet.c - $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclGet.c - -tclHash.o: $(GENERIC_DIR)/tclHash.c - $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclHash.c - -tclHistory.o: $(GENERIC_DIR)/tclHistory.c - $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclHistory.c - -tclIndexObj.o: $(GENERIC_DIR)/tclIndexObj.c - $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclIndexObj.c - -tclInterp.o: $(GENERIC_DIR)/tclInterp.c - $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclInterp.c - -tclIO.o: $(GENERIC_DIR)/tclIO.c - $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclIO.c - -tclIOCmd.o: $(GENERIC_DIR)/tclIOCmd.c - $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclIOCmd.c - -tclIOGT.o: $(GENERIC_DIR)/tclIOGT.c - $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclIOGT.c - -tclIOSock.o: $(GENERIC_DIR)/tclIOSock.c - $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclIOSock.c - -tclIOUtil.o: $(GENERIC_DIR)/tclIOUtil.c - $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclIOUtil.c - -tclLink.o: $(GENERIC_DIR)/tclLink.c - $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclLink.c - -tclListObj.o: $(GENERIC_DIR)/tclListObj.c - $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclListObj.c - -tclLiteral.o: $(GENERIC_DIR)/tclLiteral.c - $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclLiteral.c - -tclObj.o: $(GENERIC_DIR)/tclObj.c - $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclObj.c - -tclLoad.o: $(GENERIC_DIR)/tclLoad.c - $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclLoad.c - -tclLoadAix.o: $(UNIX_DIR)/tclLoadAix.c - $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclLoadAix.c - -tclLoadAout.o: $(UNIX_DIR)/tclLoadAout.c - $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclLoadAout.c - -tclLoadDl.o: $(UNIX_DIR)/tclLoadDl.c - $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclLoadDl.c - -tclLoadDl2.o: $(UNIX_DIR)/tclLoadDl2.c - $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclLoadDl2.c - -tclLoadDld.o: $(UNIX_DIR)/tclLoadDld.c - $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclLoadDld.c - -tclLoadDyld.o: $(UNIX_DIR)/tclLoadDyld.c - $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclLoadDyld.c - -tclLoadNone.o: $(GENERIC_DIR)/tclLoadNone.c - $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclLoadNone.c - -tclLoadOSF.o: $(UNIX_DIR)/tclLoadOSF.c - $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclLoadOSF.c - -tclLoadShl.o: $(UNIX_DIR)/tclLoadShl.c - $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclLoadShl.c - -tclMain.o: $(GENERIC_DIR)/tclMain.c - $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclMain.c - -tclMtherr.o: $(UNIX_DIR)/tclMtherr.c - $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclMtherr.c - -tclNamesp.o: $(GENERIC_DIR)/tclNamesp.c - $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclNamesp.c - -tclNotify.o: $(GENERIC_DIR)/tclNotify.c - $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclNotify.c - -tclParse.o: $(GENERIC_DIR)/tclParse.c - $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclParse.c - -tclParseExpr.o: $(GENERIC_DIR)/tclParseExpr.c - $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclParseExpr.c - -tclPanic.o: $(GENERIC_DIR)/tclPanic.c - $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclPanic.c - -tclPipe.o: $(GENERIC_DIR)/tclPipe.c - $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclPipe.c - -tclPkg.o: $(GENERIC_DIR)/tclPkg.c - $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclPkg.c - -tclPosixStr.o: $(GENERIC_DIR)/tclPosixStr.c - $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclPosixStr.c - -tclPreserve.o: $(GENERIC_DIR)/tclPreserve.c - $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclPreserve.c - -tclProc.o: $(GENERIC_DIR)/tclProc.c - $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclProc.c - -tclRegexp.o: $(GENERIC_DIR)/tclRegexp.c - $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclRegexp.c - -tclResolve.o: $(GENERIC_DIR)/tclResolve.c - $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclResolve.c - -tclResult.o: $(GENERIC_DIR)/tclResult.c - $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclResult.c - -tclScan.o: $(GENERIC_DIR)/tclScan.c - $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclScan.c - -tclStringObj.o: $(GENERIC_DIR)/tclStringObj.c - $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclStringObj.c - -tclStubInit.o: $(GENERIC_DIR)/tclStubInit.c - $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclStubInit.c - -tclUtil.o: $(GENERIC_DIR)/tclUtil.c - $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclUtil.c - -tclUtf.o: $(GENERIC_DIR)/tclUtf.c - $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclUtf.c - -tclVar.o: $(GENERIC_DIR)/tclVar.c - $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclVar.c - -tclTest.o: $(GENERIC_DIR)/tclTest.c - $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclTest.c - -tclTestObj.o: $(GENERIC_DIR)/tclTestObj.c - $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclTestObj.c - -tclTestProcBodyObj.o: $(GENERIC_DIR)/tclTestProcBodyObj.c - $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclTestProcBodyObj.c - -tclTimer.o: $(GENERIC_DIR)/tclTimer.c - $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclTimer.c - -tclThread.o: $(GENERIC_DIR)/tclThread.c - $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclThread.c - -tclThreadTest.o: $(GENERIC_DIR)/tclThreadTest.c - $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclThreadTest.c - -tclUnixChan.o: $(UNIX_DIR)/tclUnixChan.c - $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclUnixChan.c - -tclUnixEvent.o: $(UNIX_DIR)/tclUnixEvent.c - $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclUnixEvent.c - -tclUnixFCmd.o: $(UNIX_DIR)/tclUnixFCmd.c - $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclUnixFCmd.c - -tclUnixFile.o: $(UNIX_DIR)/tclUnixFile.c - $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclUnixFile.c - -tclUnixNotfy.o: $(UNIX_DIR)/tclUnixNotfy.c - $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclUnixNotfy.c - -tclUnixPipe.o: $(UNIX_DIR)/tclUnixPipe.c - $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclUnixPipe.c - -tclUnixSock.o: $(UNIX_DIR)/tclUnixSock.c - $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclUnixSock.c - -tclUnixTest.o: $(UNIX_DIR)/tclUnixTest.c - $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclUnixTest.c - -tclUnixThrd.o: $(UNIX_DIR)/tclUnixThrd.c - $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclUnixThrd.c - -tclUnixTime.o: $(UNIX_DIR)/tclUnixTime.c - $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclUnixTime.c - -tclUnixInit.o: $(UNIX_DIR)/tclUnixInit.c $(GENERIC_DIR)/tclInitScript.h tclConfig.sh - $(CC) -c $(CC_SWITCHES) -DTCL_LIBRARY=\"${TCL_LIBRARY}\" \ - -DTCL_PACKAGE_PATH="\"${TCL_PACKAGE_PATH}\"" \ - $(UNIX_DIR)/tclUnixInit.c - -# The following targets are not completely general. They are provide -# purely for documentation purposes so people who are interested in -# the Xt based notifier can modify them to suit their own installation. - -xttest: ${XTTEST_OBJS} ${GENERIC_OBJS} ${UNIX_OBJS} ${COMPAT_OBJS} \ - @DL_OBJS@ ${BUILD_DLTEST} - ${CC} ${XTTEST_OBJS} ${GENERIC_OBJS} ${UNIX_OBJS} ${COMPAT_OBJS} \ - @DL_OBJS@ @TCL_BUILD_LIB_SPEC@ ${LIBS} \ - @TCL_LD_SEARCH_FLAGS@ -L/usr/openwin/lib -lXt -o xttest - -tclXtNotify.o: $(UNIX_DIR)/tclXtNotify.c - $(CC) -c $(CC_SWITCHES) -I/usr/openwin/include \ - $(UNIX_DIR)/tclXtNotify.c - -tclXtTest.o: $(UNIX_DIR)/tclXtTest.c - $(CC) -c $(CC_SWITCHES) -I/usr/openwin/include \ - $(UNIX_DIR)/tclXtTest.c - -# compat binaries, these must be compiled for use in a shared library -# even though they may be placed in a static executable or library. Since -# they are included in both the tcl library and the stub library, they -# need to be relocatable. - -fixstrtod.o: $(COMPAT_DIR)/fixstrtod.c - $(CC) -c $(STUB_CC_SWITCHES) $(COMPAT_DIR)/fixstrtod.c - -getcwd.o: $(COMPAT_DIR)/getcwd.c - $(CC) -c $(STUB_CC_SWITCHES) $(COMPAT_DIR)/getcwd.c - -opendir.o: $(COMPAT_DIR)/opendir.c - $(CC) -c $(STUB_CC_SWITCHES) $(COMPAT_DIR)/opendir.c - -memcmp.o: $(COMPAT_DIR)/memcmp.c - $(CC) -c $(STUB_CC_SWITCHES) $(COMPAT_DIR)/memcmp.c - -strncasecmp.o: $(COMPAT_DIR)/strncasecmp.c - $(CC) -c $(STUB_CC_SWITCHES) $(COMPAT_DIR)/strncasecmp.c - -strstr.o: $(COMPAT_DIR)/strstr.c - $(CC) -c $(STUB_CC_SWITCHES) $(COMPAT_DIR)/strstr.c - -strtod.o: $(COMPAT_DIR)/strtod.c - $(CC) -c $(STUB_CC_SWITCHES) $(COMPAT_DIR)/strtod.c - -strtol.o: $(COMPAT_DIR)/strtol.c - $(CC) -c $(STUB_CC_SWITCHES) $(COMPAT_DIR)/strtol.c - -strtoul.o: $(COMPAT_DIR)/strtoul.c - $(CC) -c $(STUB_CC_SWITCHES) $(COMPAT_DIR)/strtoul.c - -tmpnam.o: $(COMPAT_DIR)/tmpnam.c - $(CC) -c $(STUB_CC_SWITCHES) $(COMPAT_DIR)/tmpnam.c - -waitpid.o: $(COMPAT_DIR)/waitpid.c - $(CC) -c $(STUB_CC_SWITCHES) $(COMPAT_DIR)/waitpid.c - -# Stub library binaries, these must be compiled for use in a shared library -# even though they will be placed in a static archive - - -tclStubLib.o: $(GENERIC_DIR)/tclStubLib.c - $(CC) -c $(STUB_CC_SWITCHES) $(GENERIC_DIR)/tclStubLib.c - -.c.o: - $(CC) -c $(CC_SWITCHES) $< - -# -# Target to regenerate header files and stub files from the *.decls tables. -# - -$(GENERIC_DIR)/tclStubInit.c: $(GENERIC_DIR)/tcl.decls \ - $(GENERIC_DIR)/tclInt.decls - $(TCL_EXE) $(TOOL_DIR)/genStubs.tcl $(GENERIC_DIR) \ - $(GENERIC_DIR)/tcl.decls $(GENERIC_DIR)/tclInt.decls - -genstubs: - $(TCL_EXE) $(TOOL_DIR)/genStubs.tcl $(GENERIC_DIR) \ - $(GENERIC_DIR)/tcl.decls $(GENERIC_DIR)/tclInt.decls - -# -# Target to check that all exported functions have an entry in the stubs -# tables. -# - -checkstubs: - -@for i in `nm -p $(TCL_LIB_FILE) | awk '$$2 ~ /T/ { print $$3 }' \ - | sort -n`; do \ - match=0; \ - for j in $(TCL_DECLS); do \ - if [ `grep -c $$i $$j` -gt 0 ]; then \ - match=1; \ - fi; \ - done; \ - if [ $$match -eq 0 ]; then echo $$i; fi \ - done - -# -# Target to check for proper usage of UCHAR macro. -# - -checkuchar: - -egrep isalnum\|isalpha\|iscntrl\|isdigit\|islower\|isprint\|ispunct\|isspace\|isupper\|isxdigit\|toupper\|tolower $(SRCS) | grep -v UCHAR - -# -# Target to make sure that only symbols with "Tcl" prefixes are -# exported. -# - -checkexports: $(TCL_LIB_FILE) - -nm -p $(TCL_LIB_FILE) | awk '$$2 ~ /[TDB]/ { print $$3 }' | sort -n | grep -v '^[Tt]cl' - -# -# Target to create a Tcl RPM for Linux. Requires that you be on a Linux -# system. -# - -rpm: all /bin/rpm - rm -f THIS.TCL.SPEC - echo "%define _builddir `pwd`" > THIS.TCL.SPEC - echo "%define _rpmdir `pwd`/RPMS" >> THIS.TCL.SPEC - cat tcl.spec >> THIS.TCL.SPEC - mkdir -p RPMS/i386 - rpm -bb THIS.TCL.SPEC - mv RPMS/i386/*.rpm . - rm -rf RPMS THIS.TCL.SPEC - -# -# Target to create a proper Tcl distribution from information in the -# master source directory. DISTDIR must be defined to indicate where -# to put the distribution. -# - -DISTROOT = /tmp/dist -DISTNAME = tcl@TCL_VERSION@@TCL_PATCH_LEVEL@ -ZIPNAME = tcl@TCL_MAJOR_VERSION@@TCL_MINOR_VERSION@@TCL_PATCH_LEVEL@.zip -DISTDIR = $(DISTROOT)/$(DISTNAME) -$(UNIX_DIR)/configure: $(UNIX_DIR)/configure.in - autoconf $(UNIX_DIR)/configure.in > $(UNIX_DIR)/configure -dist: $(UNIX_DIR)/configure - rm -rf $(DISTDIR) - mkdir $(DISTDIR) - mkdir $(DISTDIR)/unix - cp -p $(UNIX_DIR)/*.c $(UNIX_DIR)/*.h $(DISTDIR)/unix - rm -f $(DISTDIR)/unix/bp.c - cp $(UNIX_DIR)/Makefile.in $(DISTDIR)/unix - chmod 664 $(DISTDIR)/unix/Makefile.in - cp $(UNIX_DIR)/configure $(UNIX_DIR)/configure.in \ - $(UNIX_DIR)/tcl.m4 $(UNIX_DIR)/aclocal.m4 \ - $(UNIX_DIR)/tclConfig.sh.in $(UNIX_DIR)/install-sh \ - $(UNIX_DIR)/README $(UNIX_DIR)/ldAix $(UNIX_DIR)/tcl.spec \ - $(DISTDIR)/unix - chmod 775 $(DISTDIR)/unix/configure $(DISTDIR)/unix/configure.in - chmod 775 $(DISTDIR)/unix/ldAix - chmod +x $(DISTDIR)/unix/install-sh - - $(TCL_EXE) $(UNIX_DIR)/mkLinks.tcl \ - $(UNIX_DIR)/../doc/*.[13n] > $(DISTDIR)/unix/mkLinks - chmod +x $(DISTDIR)/unix/mkLinks - mkdir $(DISTDIR)/generic - cp -p $(GENERIC_DIR)/*.c $(GENERIC_DIR)/*.h $(DISTDIR)/generic - cp -p $(GENERIC_DIR)/*.decls $(DISTDIR)/generic - cp -p $(GENERIC_DIR)/README $(DISTDIR)/generic - cp -p $(GENERIC_DIR)/tclGetDate.y $(DISTDIR)/generic - cp -p $(TOP_DIR)/changes $(TOP_DIR)/ChangeLog $(TOP_DIR)/README* \ - $(TOP_DIR)/license.terms $(DISTDIR) - mkdir $(DISTDIR)/library - cp -p $(TOP_DIR)/license.terms $(TOP_DIR)/library/*.tcl \ - $(TOP_DIR)/library/tclIndex $(DISTDIR)/library - for i in http2.3 http1.0 opt0.4 msgcat1.0 reg1.0 dde1.1 tcltest1.0; \ - do \ - mkdir $(DISTDIR)/library/$$i ;\ - cp -p $(TOP_DIR)/library/$$i/*.tcl $(DISTDIR)/library/$$i; \ - done; - mkdir $(DISTDIR)/library/encoding - cp -p $(TOP_DIR)/library/encoding/*.enc $(DISTDIR)/library/encoding - mkdir $(DISTDIR)/doc - cp -p $(TOP_DIR)/license.terms $(TOP_DIR)/doc/*.[13n] \ - $(TOP_DIR)/doc/man.macros $(DISTDIR)/doc - mkdir $(DISTDIR)/compat - cp -p $(TOP_DIR)/license.terms $(TOP_DIR)/compat/*.c \ - $(TOP_DIR)/compat/*.h $(TOP_DIR)/compat/README \ - $(DISTDIR)/compat - mkdir $(DISTDIR)/tests - cp -p $(TOP_DIR)/license.terms $(DISTDIR)/tests - cp -p $(TOP_DIR)/tests/*.test $(TOP_DIR)/tests/README \ - $(TOP_DIR)/tests/httpd $(TOP_DIR)/tests/*.tcl \ - $(DISTDIR)/tests - mkdir $(DISTDIR)/tests/pkg - cp -p $(TOP_DIR)/license.terms $(DISTDIR)/tests/pkg - cp -p $(TOP_DIR)/tests/pkg/*.tcl $(DISTDIR)/tests/pkg - mkdir $(DISTDIR)/win - cp $(TOP_DIR)/win/Makefile.in $(DISTDIR)/win - cp $(TOP_DIR)/win/configure.in \ - $(TOP_DIR)/win/configure \ - $(TOP_DIR)/win/tclConfig.sh.in \ - $(TOP_DIR)/win/tcl.m4 $(TOP_DIR)/win/aclocal.m4 \ - $(DISTDIR)/win - cp -p $(TOP_DIR)/win/*.c $(TOP_DIR)/win/*.h $(TOP_DIR)/win/*.rc \ - $(TOP_DIR)/win/*.ico $(DISTDIR)/win - cp -p $(TOP_DIR)/win/*.bat $(DISTDIR)/win - cp -p $(TOP_DIR)/win/makefile.* $(DISTDIR)/win - cp -p $(TOP_DIR)/win/README $(DISTDIR)/win - cp -p $(TOP_DIR)/license.terms $(DISTDIR)/win - mkdir $(DISTDIR)/mac - cp -p $(TOP_DIR)/mac/tclMacProjects.sea.hqx $(DISTDIR)/mac - cp -p $(TOP_DIR)/mac/*.c $(TOP_DIR)/mac/*.h $(TOP_DIR)/mac/*.r \ - $(DISTDIR)/mac - cp -p $(TOP_DIR)/mac/porting.notes $(TOP_DIR)/mac/README $(DISTDIR)/mac - cp -p $(TOP_DIR)/mac/*.exp $(TOP_DIR)/mac/*.pch $(DISTDIR)/mac - cp -p $(TOP_DIR)/mac/*.doc $(DISTDIR)/mac - cp -p $(TOP_DIR)/mac/*.html $(DISTDIR)/mac - cp -p $(TOP_DIR)/license.terms $(DISTDIR)/mac - mkdir $(DISTDIR)/unix/dltest - cp -p $(UNIX_DIR)/dltest/*.c $(UNIX_DIR)/dltest/Makefile.in \ - $(DISTDIR)/unix/dltest - cp -p $(UNIX_DIR)/dltest/configure.in $(UNIX_DIR)/dltest/configure \ - $(UNIX_DIR)/dltest/README $(DISTDIR)/unix/dltest - mkdir $(DISTDIR)/tools - cp -p $(TOP_DIR)/tools/Makefile.in \ - $(TOP_DIR)/tools/README \ - $(TOP_DIR)/tools/configure.in \ - $(TOP_DIR)/tools/*.tcl \ - $(TOP_DIR)/tools/man2tcl.c \ - $(TOP_DIR)/tools/tcl.wse.in \ - $(TOP_DIR)/tools/*.bmp \ - $(TOP_DIR)/tools/tcl.hpj.in \ - $(DISTDIR)/tools - -# -# The following target can only be used for non-patch releases. Use -# the "allpatch" target below for patch releases. -# - -alldist: dist - rm -f $(DISTROOT)/$(DISTNAME).tar.Z \ - $(DISTROOT)/$(DISTNAME).tar.gz \ - $(DISTROOT)/$(ZIPNAME) - cd $(DISTROOT); tar cf $(DISTNAME).tar $(DISTNAME); \ - gzip -9 -c $(DISTNAME).tar > $(DISTNAME).tar.gz; \ - compress $(DISTNAME).tar; zip -qr8 $(ZIPNAME) $(DISTNAME) - -# -# The target below is similar to "alldist" except it works for patch -# releases. It is needed because patch releases are peculiar: the -# patch designation appears in the name of the compressed file -# (e.g. tcl8.0p1.tar.gz) but the extracted source directory doesn't -# include the patch designation (e.g. tcl8.0). -# - -allpatch: dist - rm -f $(DISTROOT)/$(DISTNAME).tar.Z \ - $(DISTROOT)/$(DISTNAME).tar.gz \ - $(DISTROOT)/$(ZIPNAME) - mv $(DISTROOT)/tcl${VERSION} $(DISTROOT)/old - mv $(DISTROOT)/$(DISTNAME) $(DISTROOT)/tcl${VERSION} - cd $(DISTROOT); tar cf $(DISTNAME).tar tcl${VERSION}; \ - gzip -9 -c $(DISTNAME).tar > $(DISTNAME).tar.gz; \ - compress $(DISTNAME).tar; zip -r8 $(ZIPNAME) tcl${VERSION} - mv $(DISTROOT)/tcl${VERSION} $(DISTROOT)/$(DISTNAME) - mv $(DISTROOT)/old $(DISTROOT)/tcl${VERSION} - -# -# This target creates the HTML folder for Tcl & Tk and places it -# in DISTDIR/html. It uses the tcltk-man2html.tcl tool from -# the Tcl group's tool workspace. It depends on the Tcl & Tk being -# in directories called tcl8.3 & tk8.3 up two directories from the -# TOOL_DIR. -# - -html: - $(TCL_EXE) $(TOOL_DIR)/tcltk-man2html.tcl --htmldir=$(DISTDIR)/html \ - --srcdir=$(TOP_DIR)/.. - -# -# Target to create a Macintosh version of the distribution. This will -# do a normal distribution and then massage the output to prepare it -# for moving to the Mac platform. This requires a few scripts and -# programs found only in the Tcl group's tool workspace. -# - -macdist: dist machtml - -machtml: - rm -f $(DISTDIR)/mac/tclMacProjects.sea.hqx - rm -rf $(DISTDIR)/doc - $(TCL_EXE) $(TOOL_DIR)/cvtEOL.tcl $(DISTDIR) - -# -# Targets to build Solaris package of the distribution for the current -# architecture. To build stream packages for both sun4 and i86pc -# architectures: -# -# On the sun4 machine, execute the following: -# make distclean; ./configure -# make DISTDIR=<distdir> package -# -# Once the build is complete, execute the following on the i86pc -# machine: -# make DISTDIR=<distdir> package-quick -# -# <distdir> is the absolute path to a directory where the build should -# take place. These steps will generate the $(PACKAGE).sun4 and -# $(PACKAGE).i86pc stream packages. It is important that the packages be -# built in this fashion in order to ensure that the architecture -# independent files are exactly the same, including timestamps, in -# both packages. -# - -PACKAGE=SCRPtcl - -package: dist package-config package-common package-binaries package-generate -package-quick: package-config package-binaries package-generate - -# -# Configure for the current architecture in the dist directory. -# -package-config: - mkdir -p $(DISTDIR)/unix/`arch` - cd $(DISTDIR)/unix/`arch`; \ - ../configure --prefix=/opt/$(PACKAGE)/$(VERSION) \ - --exec_prefix=/opt/$(PACKAGE)/$(VERSION)/`arch` \ - --enable-shared - mkdir -p $(DISTDIR)/$(PACKAGE)/$(VERSION) - mkdir -p $(DISTDIR)/$(PACKAGE)/$(VERSION)/`arch` - -# -# Build and install the architecture independent files in the dist directory. -# - -package-common: - cd $(DISTDIR)/unix/`arch`;\ - $(MAKE); \ - $(MAKE) prefix=$(DISTDIR)/$(PACKAGE)/$(VERSION) \ - exec_prefix=$(DISTDIR)/$(PACKAGE)/$(VERSION)/`arch` \ - install-libraries install-man - mkdir -p $(DISTDIR)/$(PACKAGE)/$(VERSION)/bin - sed -e "s/TCLVERSION/$(VERSION)/g" < $(UNIX_DIR)/tclsh.sh \ - > $(DISTDIR)/$(PACKAGE)/$(VERSION)/bin/tclsh$(VERSION) - chmod 755 $(DISTDIR)/$(PACKAGE)/$(VERSION)/bin/tclsh$(VERSION) - -# -# Build and install the architecture specific files in the dist directory. -# - -package-binaries: - cd $(DISTDIR)/unix/`arch`; \ - $(MAKE); \ - $(MAKE) install-binaries prefix=$(DISTDIR)/$(PACKAGE)/$(VERSION) \ - exec_prefix=$(DISTDIR)/$(PACKAGE)/$(VERSION)/`arch` - -# -# Generate a package from the installed files in the dist directory for the -# current architecture. -# - -package-generate: - pkgproto $(DISTDIR)/$(PACKAGE)/$(VERSION)/bin=bin \ - $(DISTDIR)/$(PACKAGE)/$(VERSION)/include=include \ - $(DISTDIR)/$(PACKAGE)/$(VERSION)/lib=lib \ - $(DISTDIR)/$(PACKAGE)/$(VERSION)/man=man \ - $(DISTDIR)/$(PACKAGE)/$(VERSION)/`arch`=`arch` \ - | $(TCL_EXE) $(UNIX_DIR)/mkProto.tcl \ - $(VERSION) $(UNIX_DIR) > prototype - pkgmk -o -d . -f prototype -a `arch` - pkgtrans -s . $(PACKAGE).`arch` $(PACKAGE) - rm -rf $(PACKAGE) - -# DO NOT DELETE THIS LINE -- make depend depends on it. diff --git a/unix/README b/unix/README deleted file mode 100644 index 683ca57..0000000 --- a/unix/README +++ /dev/null @@ -1,132 +0,0 @@ -Tcl UNIX README ---------------- - -This is the directory where you configure, compile, test, and install -UNIX versions of Tcl. This directory also contains source files for Tcl -that are specific to UNIX. Some of the files in this directory are -used on the PC or Mac platform too, but they all depend on UNIX -(POSIX/ANSI C) interfaces and some of them only make sense under UNIX. - -Updated forms of the information found in this file is available at: - http://dev.scriptics.com/doc/howto/compile.html#unix - -For information on platforms where Tcl is known to compile, along -with any porting notes for getting it to work on those platforms, see: - http://dev.scriptics.com/software/tcltk/platforms.html - -The rest of this file contains instructions on how to do this. The -release should compile and run either "out of the box" or with trivial -changes on any UNIX-like system that approximates POSIX, BSD, or System -V. We know that it runs on workstations from Sun, H-P, DEC, IBM, and -SGI, as well as PCs running Linux, BSDI, and SCO UNIX. To compile for -a PC running Windows, see the README file in the directory ../win. To -compile for a Macintosh, see the README file in the directory ../mac. - -RCS: @(#) $Id: README,v 1.11 2000/04/26 17:31:21 hobbs Exp $ - -How To Compile And Install Tcl: -------------------------------- - -(a) Check for patches as described in ../README. - -(b) If you have already compiled Tcl once in this directory and are now - preparing to compile again in the same directory but for a different - platform, or if you have applied patches, type "make distclean" to - discard all the configuration information computed previously. - -(c) If there is no "configure" script in this directory it is because you - are working out of the source repository (i.e., CVS) instead of working - from a source distribution. In this case you need to use "autoconf" - to generate the configure script. It runs with no arguments. - Remember to run it here and down in the dltest directory. - - (in the tcl/unix directory) - autoconf - cd dltest ; autoconf ; cd .. - -(d) Type "./configure". This runs a configuration script created by GNU - autoconf, which configures Tcl for your system and creates a - Makefile. The configure script allows you to customize the Tcl - configuration for your site; for details on how you can do this, - type "./configure -help" or refer to the autoconf documentation (not - included here). Tcl's "configure" supports the following special - switches in addition to the standard ones: - --enable-gcc If this switch is set, Tcl will configure - itself to use gcc if it is available on your - system. Note: it is not safe to modify the - Makefile to use gcc after configure is run; - if you do this, then information related to - dynamic linking will be incorrect. - --enable-threads If this switch is set, Tcl will compile - itself with multithreading support. - --disable-load If this switch is specified then Tcl will - configure itself not to allow dynamic loading, - even if your system appears to support it. - Normally you can leave this switch out and - Tcl will build itself for dynamic loading - if your system supports it. - --enable-shared If this switch is specified, Tcl will compile - itself as a shared library if it can figure - out how to do that on this platform. This - is the default on platforms where we know - how to build shared libraries. - --disable-shared If this switch is specified, Tcl will compile - itself as a static library. - Note: be sure to use only absolute path names (those starting with "/") - in the --prefix and --exec_prefix options. - -(e) Type "make". This will create a library archive called - "libtcl<version>.a" or "libtcl<version>.so" and an interpreter - application called "tclsh" that allows you to type Tcl commands - interactively or execute script files. - -(f) If the make fails then you'll have to personalize the Makefile - for your site or possibly modify the distribution in other ways. - First check the porting Web page above to see if there are hints - for compiling on your system. If you need to modify Makefile, - are comments at the beginning of it that describe the things you - might want to change and how to change them. - -(g) Type "make install" to install Tcl binaries and script files in - standard places. You'll need write permission on the installation - directories to do this. The installation directories are - determined by the "configure" script and may be specified with - the --prefix and --exec_prefix options to "configure". See the - Makefile for information on what directories were chosen; you - can override these choices by modifying the "prefix" and - "exec_prefix" variables in the Makefile. - -(h) At this point you can play with Tcl by invoking the "tclsh" - program and typing Tcl commands. However, if you haven't installed - Tcl then you'll first need to set your TCL_LIBRARY variable to - hold the full path name of the "library" subdirectory. Note that - the installed versions of tclsh, libtcl.a, and libtcl.so have a - version number in their names, such as "tclsh8.3" or "libtcl8.3.so"; - to use the installed versions, either specify the version number - or create a symbolic link (e.g. from "tclsh" to "tclsh8.3"). - -If you have trouble compiling Tcl, see the URL noted above about working -platforms. It contains information that people have provided about changes -they had to make to compile Tcl in various environments. We're also -interested in hearing how to change the configuration setup so that Tcl -compiles on additional platforms "out of the box". - -Test suite ----------- - -There is a relatively complete test suite for all of the Tcl core in -the subdirectory "tests". To use it just type "make test" in this -directory. You should then see a printout of the test files processed. -If any errors occur, you'll see a much more substantial printout for -each error. See the README file in the "tests" directory for more -information on the test suite. Note: don't run the tests as superuser: -this will cause several of them to fail. If a test is failing -consistently, please send us a bug report with as much detail as you -can manage. Please use the online database at - http://dev.scriptics.com/ticket/ - -The Tcl test suite is very sensitive to proper implementation of -ANSI C library procedures such as sprintf and sscanf. If the test -suite generates errors, most likely they are due to non-conformance -of your system's ANSI C library; such problems are unlikely to -affect any real applications so it's probably safe to ignore them. diff --git a/unix/aclocal.m4 b/unix/aclocal.m4 deleted file mode 100644 index bc7540d..0000000 --- a/unix/aclocal.m4 +++ /dev/null @@ -1 +0,0 @@ -builtin(include,tcl.m4) diff --git a/unix/configure.in b/unix/configure.in deleted file mode 100644 index 26cd939..0000000 --- a/unix/configure.in +++ /dev/null @@ -1,597 +0,0 @@ -#! /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. -AC_INIT(../generic/tcl.h) -# RCS: @(#) $Id: configure.in,v 1.57.2.1 2000/07/27 01:39:22 hobbs Exp $ - -TCL_VERSION=8.3 -TCL_MAJOR_VERSION=8 -TCL_MINOR_VERSION=3 -TCL_PATCH_LEVEL=".2" -VERSION=${TCL_VERSION} - -#------------------------------------------------------------------------ -# Handle the --prefix=... option -#------------------------------------------------------------------------ - -if test "${prefix}" = "NONE"; then - prefix=/usr/local -fi -if test "${exec_prefix}" = "NONE"; then - exec_prefix=$prefix -fi -TCL_SRC_DIR=`cd $srcdir/..; pwd` - -#------------------------------------------------------------------------ -# Standard compiler checks -#------------------------------------------------------------------------ - -AC_PROG_RANLIB -SC_ENABLE_GCC -AC_HAVE_HEADERS(unistd.h limits.h) - -#------------------------------------------------------------------------ -# Threads support -#------------------------------------------------------------------------ - -SC_ENABLE_THREADS - -#------------------------------------------------------------------------ -# If we're using GCC, see if the compiler understands -pipe. If so, use it. -# It makes compiling go faster. (This is only a performance feature.) -#------------------------------------------------------------------------ - -if test -z "$no_pipe"; then -if test -n "$GCC"; then - AC_MSG_CHECKING([if the compiler understands -pipe]) - OLDCC="$CC" - CC="$CC -pipe" - AC_TRY_COMPILE(,, - AC_MSG_RESULT(yes), - CC="$OLDCC" - AC_MSG_RESULT(no)) -fi -fi - -#-------------------------------------------------------------------- -# Supply substitutes for missing POSIX library procedures, or -# set flags so Tcl uses alternate procedures. -#-------------------------------------------------------------------- - -# Check if Posix compliant getcwd exists, if not we'll use getwd. -AC_CHECK_FUNCS(getcwd, , AC_DEFINE(USEGETWD)) -# Nb: if getcwd uses popen and pwd(1) (like SunOS 4) we should really -# define USEGETWD even if the posix getcwd exists. Add a test ? - -AC_REPLACE_FUNCS(opendir strstr) - -AC_REPLACE_FUNCS(strtol tmpnam waitpid) -AC_CHECK_FUNC(strerror, , AC_DEFINE(NO_STRERROR)) -AC_CHECK_FUNC(getwd, , AC_DEFINE(NO_GETWD)) -AC_CHECK_FUNC(wait3, , AC_DEFINE(NO_WAIT3)) -AC_CHECK_FUNC(uname, , AC_DEFINE(NO_UNAME)) -AC_CHECK_FUNC(realpath, , AC_DEFINE(NO_REALPATH)) - -#-------------------------------------------------------------------- -# On a few very rare systems, all of the libm.a stuff is -# already in libc.a. Set compiler flags accordingly. -# Also, Linux requires the "ieee" library for math to work -# right (and it must appear before "-lm"). -#-------------------------------------------------------------------- - -#AC_CHECK_FUNC(sin, MATH_LIBS="", MATH_LIBS="-lm") -#AC_CHECK_LIB(ieee, main, [MATH_LIBS="-lieee $MATH_LIBS"]) - -#-------------------------------------------------------------------- -# On AIX systems, libbsd.a has to be linked in to support -# non-blocking file IO. This library has to be linked in after -# the MATH_LIBS or it breaks the pow() function. The way to -# insure proper sequencing, is to add it to the tail of MATH_LIBS. -# This library also supplies gettimeofday. -#-------------------------------------------------------------------- -#libbsd=no -#if test "`uname -s`" = "AIX" ; then -# AC_CHECK_LIB(bsd, gettimeofday, libbsd=yes) -# if test $libbsd = yes; then -# MATH_LIBS="$MATH_LIBS -lbsd" -# fi -#fi - -#-------------------------------------------------------------------- -# Supply substitutes for missing POSIX header files. Special -# notes: -# - stdlib.h doesn't define strtol, strtoul, or -# strtod insome versions of SunOS -# - some versions of string.h don't declare procedures such -# as strstr -#-------------------------------------------------------------------- - -SC_MISSING_POSIX_HEADERS - -#--------------------------------------------------------------------------- -# Determine which interface to use to talk to the serial port. -# Note that #include lines must begin in leftmost column for -# some compilers to recognize them as preprocessor directives. -#--------------------------------------------------------------------------- - -SC_SERIAL_PORT - -#-------------------------------------------------------------------- -# Include sys/select.h if it exists and if it supplies things -# that appear to be useful and aren't already in sys/types.h. -# This appears to be true only on the RS/6000 under AIX. Some -# systems like OSF/1 have a sys/select.h that's of no use, and -# other systems like SCO UNIX have a sys/select.h that's -# pernicious. If "fd_set" isn't defined anywhere then set a -# special flag. -#-------------------------------------------------------------------- - -AC_MSG_CHECKING([fd_set and sys/select]) -AC_TRY_COMPILE([#include <sys/types.h>], - [fd_set readMask, writeMask;], tk_ok=yes, tk_ok=no) -if test $tk_ok = no; then - AC_HEADER_EGREP(fd_mask, sys/select.h, tk_ok=yes) - if test $tk_ok = yes; then - AC_DEFINE(HAVE_SYS_SELECT_H) - fi -fi -AC_MSG_RESULT($tk_ok) -if test $tk_ok = no; then - AC_DEFINE(NO_FD_SET) -fi - -#------------------------------------------------------------------------------ -# Find out all about time handling differences. -#------------------------------------------------------------------------------ - -SC_TIME_HANDLER - -#-------------------------------------------------------------------- -# Some systems (e.g., IRIX 4.0.5) lack the st_blksize field -# in struct stat. But we might be able to use fstatfs instead. -#-------------------------------------------------------------------- -AC_STRUCT_ST_BLKSIZE -AC_CHECK_FUNC(fstatfs, , AC_DEFINE(NO_FSTATFS)) - -#-------------------------------------------------------------------- -# Some system have no memcmp or it does not work with 8 bit -# data, this checks it and add memcmp.o to LIBOBJS if needed -#-------------------------------------------------------------------- -AC_FUNC_MEMCMP - -#-------------------------------------------------------------------- -# Some system like SunOS 4 and other BSD like systems -# have no memmove (we assume they have bcopy instead). -# {The replacement define is in compat/string.h} -#-------------------------------------------------------------------- -AC_CHECK_FUNC(memmove, , AC_DEFINE(NO_MEMMOVE) AC_DEFINE(NO_STRING_H)) - -#-------------------------------------------------------------------- -# On some systems strstr is broken: it returns a pointer even -# even if the original string is empty. -#-------------------------------------------------------------------- - -AC_MSG_CHECKING([proper strstr implementation]) -AC_TRY_RUN([ -extern int strstr(); -int main() -{ - exit(strstr("\0test", "test") ? 1 : 0); -} -], tcl_ok=yes, tcl_ok=no, tcl_ok=no) -if test $tcl_ok = yes; then - AC_MSG_RESULT(yes) -else - AC_MSG_RESULT([broken, using substitute]) - LIBOBJS="$LIBOBJS strstr.o" -fi - -#-------------------------------------------------------------------- -# Check for strtoul function. This is tricky because under some -# versions of AIX strtoul returns an incorrect terminator -# pointer for the string "0". -#-------------------------------------------------------------------- - -AC_CHECK_FUNC(strtoul, tcl_ok=1, tcl_ok=0) -AC_TRY_RUN([ -extern int strtoul(); -int main() -{ - char *string = "0"; - char *term; - int value; - value = strtoul(string, &term, 0); - if ((value != 0) || (term != (string+1))) { - exit(1); - } - exit(0); -}], , tcl_ok=0, tcl_ok=0) -if test "$tcl_ok" = 0; then - test -n "$verbose" && echo " Adding strtoul.o." - LIBOBJS="$LIBOBJS strtoul.o" -fi - -#-------------------------------------------------------------------- -# Check for the strtod function. This is tricky because in some -# versions of Linux strtod mis-parses strings starting with "+". -#-------------------------------------------------------------------- - -AC_CHECK_FUNC(strtod, tcl_ok=1, tcl_ok=0) -AC_TRY_RUN([ -extern double strtod(); -int main() -{ - char *string = " +69"; - char *term; - double value; - value = strtod(string, &term); - if ((value != 69) || (term != (string+4))) { - exit(1); - } - exit(0); -}], , tcl_ok=0, tcl_ok=0) -if test "$tcl_ok" = 0; then - test -n "$verbose" && echo " Adding strtod.o." - LIBOBJS="$LIBOBJS strtod.o" -fi - -#-------------------------------------------------------------------- -# Under Solaris 2.4, strtod returns the wrong value for the -# terminating character under some conditions. Check for this -# and if the problem exists use a substitute procedure -# "fixstrtod" that corrects the error. -#-------------------------------------------------------------------- - -SC_BUGGY_STRTOD - -#-------------------------------------------------------------------- -# Check for various typedefs and provide substitutes if -# they don't exist. -#-------------------------------------------------------------------- - -AC_TYPE_MODE_T -AC_TYPE_PID_T -AC_TYPE_SIZE_T -AC_TYPE_UID_T - -#-------------------------------------------------------------------- -# If a system doesn't have an opendir function (man, that's old!) -# then we have to supply a different version of dirent.h which -# is compatible with the substitute version of opendir that's -# provided. This version only works with V7-style directories. -#-------------------------------------------------------------------- - -AC_CHECK_FUNC(opendir, , AC_DEFINE(USE_DIRENT2_H)) - -#-------------------------------------------------------------------- -# The check below checks whether <sys/wait.h> defines the type -# "union wait" correctly. It's needed because of weirdness in -# HP-UX where "union wait" is defined in both the BSD and SYS-V -# environments. Checking the usability of WIFEXITED seems to do -# the trick. -#-------------------------------------------------------------------- - -AC_MSG_CHECKING([union wait]) -AC_TRY_LINK([#include <sys/types.h> -#include <sys/wait.h>], [ -union wait x; -WIFEXITED(x); /* Generates compiler error if WIFEXITED - * uses an int. */ -], tcl_ok=yes, tcl_ok=no) -AC_MSG_RESULT($tcl_ok) -if test $tcl_ok = no; then - AC_DEFINE(NO_UNION_WAIT) -fi - -#-------------------------------------------------------------------- -# Check to see whether the system supports the matherr function -# and its associated type "struct exception". -#-------------------------------------------------------------------- - -AC_MSG_CHECKING([matherr support]) -AC_TRY_COMPILE([#include <math.h>], [ -struct exception x; -x.type = DOMAIN; -x.type = SING; -], tcl_ok=yes, tcl_ok=no) -AC_MSG_RESULT($tcl_ok) -if test $tcl_ok = yes; then - AC_DEFINE(NEED_MATHERR) -fi - -#-------------------------------------------------------------------- -# Check whether there is an strncasecmp function on this system. -# This is a bit tricky because under SCO it's in -lsocket and -# under Sequent Dynix it's in -linet. -#-------------------------------------------------------------------- - -AC_CHECK_FUNC(strncasecmp, tcl_ok=1, tcl_ok=0) -if test "$tcl_ok" = 0; then - AC_CHECK_LIB(socket, strncasecmp, tcl_ok=1, tcl_ok=0) -fi -if test "$tcl_ok" = 0; then - AC_CHECK_LIB(inet, strncasecmp, tcl_ok=1, tcl_ok=0) -fi -if test "$tcl_ok" = 0; then - LIBOBJS="$LIBOBJS strncasecmp.o" -fi - -#-------------------------------------------------------------------- -# The code below deals with several issues related to gettimeofday: -# 1. Some systems don't provide a gettimeofday function at all -# (set NO_GETTOD if this is the case). -# 2. SGI systems don't use the BSD form of the gettimeofday function, -# but they have a BSDgettimeofday function that can be used instead. -# 3. See if gettimeofday is declared in the <sys/time.h> header file. -# if not, set the GETTOD_NOT_DECLARED flag so that tclPort.h can -# declare it. -#-------------------------------------------------------------------- - -AC_CHECK_FUNC(BSDgettimeofday, AC_DEFINE(HAVE_BSDGETTIMEOFDAY), - AC_CHECK_FUNC(gettimeofday, , AC_DEFINE(NO_GETTOD))) -AC_MSG_CHECKING([for gettimeofday declaration]) -AC_EGREP_HEADER(gettimeofday, sys/time.h, AC_MSG_RESULT(present), [ - AC_MSG_RESULT(missing) - AC_DEFINE(GETTOD_NOT_DECLARED) -]) - -#-------------------------------------------------------------------- -# Interactive UNIX requires -linet instead of -lsocket, plus it -# needs net/errno.h to define the socket-related error codes. -#-------------------------------------------------------------------- - -#AC_CHECK_LIB(inet, main, [LIBS="$LIBS -linet"]) -#AC_CHECK_HEADER(net/errno.h, AC_DEFINE(HAVE_NET_ERRNO_H)) - -#-------------------------------------------------------------------- -# The following code checks to see whether it is possible to get -# signed chars on this platform. This is needed in order to -# properly generate sign-extended ints from character values. -#-------------------------------------------------------------------- - -AC_C_CHAR_UNSIGNED -AC_MSG_CHECKING([signed char declarations]) -AC_TRY_COMPILE(, [ -signed char *p; -p = 0; -], tcl_ok=yes, tcl_ok=no) -AC_MSG_RESULT($tcl_ok) -if test $tcl_ok = yes; then - AC_DEFINE(HAVE_SIGNED_CHAR) -fi - -#-------------------------------------------------------------------- -# Check for the existence of the -lsocket and -lnsl libraries. -# The order here is important, so that they end up in the right -# order in the command line generated by make. Here are some -# special considerations: -# 1. Use "connect" and "accept" to check for -lsocket, and -# "gethostbyname" to check for -lnsl. -# 2. Use each function name only once: can't redo a check because -# autoconf caches the results of the last check and won't redo it. -# 3. Use -lnsl and -lsocket only if they supply procedures that -# aren't already present in the normal libraries. This is because -# IRIX 5.2 has libraries, but they aren't needed and they're -# bogus: they goof up name resolution if used. -# 4. On some SVR4 systems, can't use -lsocket without -lnsl too. -# To get around this problem, check for both libraries together -# if -lsocket doesn't work by itself. -#-------------------------------------------------------------------- - -#tcl_checkBoth=0 -#AC_CHECK_FUNC(connect, tcl_checkSocket=0, tcl_checkSocket=1) -#if test "$tcl_checkSocket" = 1; then -# AC_CHECK_LIB(socket, main, LIBS="$LIBS -lsocket", tcl_checkBoth=1) -#fi -#if test "$tcl_checkBoth" = 1; then -# tk_oldLibs=$LIBS -# LIBS="$LIBS -lsocket -lnsl" -# AC_CHECK_FUNC(accept, tcl_checkNsl=0, [LIBS=$tk_oldLibs]) -#fi -#AC_CHECK_FUNC(gethostbyname, , AC_CHECK_LIB(nsl, main, [LIBS="$LIBS -lnsl"])) - -#-------------------------------------------------------------------- -# Look for libraries that we will need when compiling the Tcl shell -#-------------------------------------------------------------------- - -SC_TCL_LINK_LIBS - -# Add the threads support libraries - -LIBS="$LIBS$THREADS_LIBS" - -#-------------------------------------------------------------------- -# The statements below define a collection of compile flags. This -# macro depends on the value of SHARED_BUILD, and should be called -# after SC_ENABLE_SHARED checks the configure switches. -#-------------------------------------------------------------------- - -SC_CONFIG_CFLAGS - -SC_ENABLE_SYMBOLS - -TCL_DBGX=${DBGX} -CFLAGS=${CFLAGS_DEFAULT} - -#-------------------------------------------------------------------- -# The statements below check for systems where POSIX-style -# non-blocking I/O (O_NONBLOCK) doesn't work or is unimplemented. -# On these systems (mostly older ones), use the old BSD-style -# FIONBIO approach instead. -#-------------------------------------------------------------------- - -SC_BLOCKING_STYLE - -#-------------------------------------------------------------------- -# The statements below define a collection of symbols related to -# building libtcl as a shared library instead of a static library. -#-------------------------------------------------------------------- - -TCL_UNSHARED_LIB_SUFFIX=${UNSHARED_LIB_SUFFIX} -TCL_SHARED_LIB_SUFFIX=${SHARED_LIB_SUFFIX} - -SC_ENABLE_SHARED - -if test "${SHARED_BUILD}" = "1" -a "${SHLIB_SUFFIX}" != "" ; then - TCL_SHLIB_CFLAGS="${SHLIB_CFLAGS}" - TCL_LD_SEARCH_FLAGS="${LD_SEARCH_FLAGS}" - eval "TCL_LIB_FILE=libtcl${TCL_SHARED_LIB_SUFFIX}" - if test "x$DL_OBJS" = "xtclLoadAout.o"; then - MAKE_LIB="ar cr \${TCL_LIB_FILE} \${OBJS}" - else - MAKE_LIB="\${SHLIB_LD} -o \${TCL_LIB_FILE} \${OBJS} ${SHLIB_LD_LIBS}" - RANLIB=":" - fi -else - case $system in - BSD/OS*) - ;; - - AIX-*) - ;; - - *) - SHLIB_LD_LIBS="" - ;; - esac - TCL_SHLIB_CFLAGS="" - TCL_LD_SEARCH_FLAGS="${LD_SEARCH_FLAGS}" - eval "TCL_LIB_FILE=libtcl${TCL_UNSHARED_LIB_SUFFIX}" - MAKE_LIB="ar cr \${TCL_LIB_FILE} \${OBJS}" -fi - -# tclConfig.sh needs a version of the _LIB_SUFFIX that has been eval'ed -# so that the backslashes quoting the DBX braces are dropped. - -# Trick to replace DBGX with TCL_DBGX -DBGX='${TCL_DBGX}' -eval "TCL_LIB_FILE=${TCL_LIB_FILE}" - -# Note: in the following variable, it's important to use the absolute -# path name of the Tcl directory rather than "..": this is because -# AIX remembers this path and will attempt to use it at run-time to look -# up the Tcl library. - -if test "$SHARED_BUILD" = "0" -o $TCL_NEEDS_EXP_FILE = 0; then - if test "${TCL_LIB_VERSIONS_OK}" = "ok"; then - TCL_LIB_FLAG="-ltcl${TCL_VERSION}\${TCL_DBGX}" - else - TCL_LIB_FLAG="-ltcl`echo ${TCL_VERSION} | tr -d .`\${TCL_DBGX}" - fi - TCL_BUILD_LIB_SPEC="-L`pwd` ${TCL_LIB_FLAG}" - TCL_LIB_SPEC="-L${exec_prefix}/lib ${TCL_LIB_FLAG}" -else - TCL_BUILD_EXP_FILE="lib.exp" - eval "TCL_EXP_FILE=libtcl${TCL_EXPORT_FILE_SUFFIX}" - - # Replace DBGX with TCL_DBGX - eval "TCL_EXP_FILE=\"${TCL_EXP_FILE}\"" - - if test "$using_gcc" = "yes" ; then - TCL_BUILD_LIB_SPEC="-Wl,-bI:`pwd`/${TCL_BUILD_EXP_FILE} -L`pwd`" - TCL_LIB_SPEC="-Wl,-bI:${exec_prefix}/lib/${TCL_EXP_FILE} -L`pwd`" - else - TCL_BUILD_LIB_SPEC="-bI:`pwd`/${TCL_BUILD_EXP_FILE}" - TCL_LIB_SPEC="-bI:${exec_prefix}/lib/${TCL_EXP_FILE}" - fi -fi -VERSION='${VERSION}' -eval "CFG_TCL_SHARED_LIB_SUFFIX=${TCL_SHARED_LIB_SUFFIX}" -eval "CFG_TCL_UNSHARED_LIB_SUFFIX=${TCL_UNSHARED_LIB_SUFFIX}" -eval "CFG_TCL_EXPORT_FILE_SUFFIX=${TCL_EXPORT_FILE_SUFFIX}" -VERSION=${TCL_VERSION} - -#-------------------------------------------------------------------- -# The statements below define the symbol TCL_PACKAGE_PATH, which -# gives a list of directories that may contain packages. The list -# consists of one directory for machine-dependent binaries and -# another for platform-independent scripts. -#-------------------------------------------------------------------- - -if test "$prefix" != "$exec_prefix"; then - TCL_PACKAGE_PATH="${exec_prefix}/lib ${prefix}/lib" -else - TCL_PACKAGE_PATH="${prefix}/lib" -fi - -#-------------------------------------------------------------------- -# The statements below define various symbols relating to Tcl -# stub support. -#-------------------------------------------------------------------- - -# Replace ${VERSION} with contents of ${TCL_VERSION} -eval "STUB_LIB_FILE=libtclstub${TCL_UNSHARED_LIB_SUFFIX}" -# Replace DBGX with TCL_DBGX -eval "STUB_LIB_FILE=\"${STUB_LIB_FILE}\"" - -MAKE_STUB_LIB="ar cr \${STUB_LIB_FILE} \${STUB_LIB_OBJS}" - -TCL_STUB_LIB_FILE=${STUB_LIB_FILE} - -if test "${TCL_LIB_VERSIONS_OK}" = "ok"; then - TCL_STUB_LIB_FLAG="-ltclstub${TCL_VERSION}\${TCL_DBGX}" -else - TCL_STUB_LIB_FLAG="-ltclstub`echo ${TCL_VERSION} | tr -d .`\${TCL_DBGX}" -fi - -TCL_BUILD_STUB_LIB_SPEC="-L`pwd` ${TCL_STUB_LIB_FLAG}" -TCL_STUB_LIB_SPEC="-L${exec_prefix}/lib ${TCL_STUB_LIB_FLAG}" -TCL_BUILD_STUB_LIB_PATH="`pwd`/${TCL_STUB_LIB_FILE}" -TCL_STUB_LIB_PATH="${exec_prefix}/lib/${TCL_STUB_LIB_FILE}" - -#------------------------------------------------------------------------ -# tclConfig.sh refers to this by a different name -#------------------------------------------------------------------------ - -TCL_SHARED_BUILD=${SHARED_BUILD} - -AC_SUBST(STUB_LIB_FILE) - -AC_SUBST(TCL_STUB_LIB_FILE) -AC_SUBST(TCL_STUB_LIB_FLAG) -AC_SUBST(TCL_BUILD_STUB_LIB_SPEC) -AC_SUBST(TCL_STUB_LIB_SPEC) -AC_SUBST(TCL_BUILD_STUB_LIB_PATH) -AC_SUBST(TCL_STUB_LIB_PATH) -AC_SUBST(MAKE_STUB_LIB) - -AC_SUBST(BUILD_DLTEST) -AC_SUBST(CFLAGS) -AC_SUBST(CFG_TCL_SHARED_LIB_SUFFIX) -AC_SUBST(CFG_TCL_UNSHARED_LIB_SUFFIX) -AC_SUBST(CFG_TCL_EXPORT_FILE_SUFFIX) -AC_SUBST(TCL_DBGX) -AC_SUBST(DL_OBJS) -AC_SUBST(EXTRA_CFLAGS) -AC_SUBST(LDFLAGS) -AC_SUBST(MAKE_LIB) -AC_SUBST(TCL_SHARED_BUILD) -AC_SUBST(SHLIB_CFLAGS) -AC_SUBST(SHLIB_LD) -AC_SUBST(STLIB_LD) -AC_SUBST(SHLIB_LD_LIBS) -AC_SUBST(SHLIB_SUFFIX) -AC_SUBST(TCL_BUILD_LIB_SPEC) -AC_SUBST(TCL_LD_SEARCH_FLAGS) -AC_SUBST(TCL_LDFLAGS_DEBUG) -AC_SUBST(TCL_LDFLAGS_OPTIMIZE) -AC_SUBST(TCL_LIB_FILE) -AC_SUBST(TCL_LIB_FLAG) -AC_SUBST(TCL_NEEDS_EXP_FILE) -AC_SUBST(TCL_BUILD_EXP_FILE) -AC_SUBST(TCL_EXP_FILE) -AC_SUBST(TCL_LIB_SPEC) -AC_SUBST(TCL_LIB_VERSIONS_OK) -AC_SUBST(TCL_MAJOR_VERSION) -AC_SUBST(TCL_MINOR_VERSION) -AC_SUBST(TCL_PACKAGE_PATH) -AC_SUBST(TCL_PATCH_LEVEL) -AC_SUBST(TCL_SHARED_LIB_SUFFIX) -AC_SUBST(TCL_SHLIB_CFLAGS) -AC_SUBST(TCL_SRC_DIR) -AC_SUBST(TCL_BIN_DIR) -AC_SUBST(TCL_UNSHARED_LIB_SUFFIX) -AC_SUBST(TCL_VERSION) - -AC_OUTPUT(Makefile tclConfig.sh) diff --git a/unix/dltest/Makefile.in b/unix/dltest/Makefile.in deleted file mode 100644 index 98188aa..0000000 --- a/unix/dltest/Makefile.in +++ /dev/null @@ -1,47 +0,0 @@ -# This Makefile is used to create several test cases for Tcl's load -# command. It also illustrates how to take advantage of configuration -# exported by Tcl to set up Makefiles for shared libraries. -# RCS: @(#) $Id: Makefile.in,v 1.6 1999/09/21 06:37:32 hobbs Exp $ - -TCL_DBGX = @TCL_DBGX@ -CC = @CC@ -LIBS = @TCL_BUILD_STUB_LIB_SPEC@ @TCL_LIBS@ -lc -AC_FLAGS = @EXTRA_CFLAGS@ -SHLIB_CFLAGS = @SHLIB_CFLAGS@ -SHLIB_LD = @SHLIB_LD@ -SHLIB_SUFFIX = @SHLIB_SUFFIX@ -SHLIB_VERSION = @SHLIB_VERSION@ -SRC_DIR = @srcdir@ -TCL_VERSION= @TCL_VERSION@ - -CFLAGS = -g -CC_SWITCHES = $(CFLAGS) -I${SRC_DIR}/../../generic -DTCL_MEM_DEBUG \ - ${SHLIB_CFLAGS} -DUSE_TCL_STUBS ${AC_FLAGS} - -all: pkga${SHLIB_SUFFIX} pkgb${SHLIB_SUFFIX} pkgc${SHLIB_SUFFIX} pkgd${SHLIB_SUFFIX} pkge${SHLIB_SUFFIX} - -pkga${SHLIB_SUFFIX}: $(SRC_DIR)/pkga.c - $(CC) -c $(CC_SWITCHES) $(SRC_DIR)/pkga.c - ${SHLIB_LD} -o pkga${SHLIB_SUFFIX} pkga.o ${LIBS} - -pkgb${SHLIB_SUFFIX}: $(SRC_DIR)/pkgb.c - $(CC) -c $(CC_SWITCHES) $(SRC_DIR)/pkgb.c - ${SHLIB_LD} -o pkgb${SHLIB_SUFFIX} pkgb.o ${LIBS} - -pkgc${SHLIB_SUFFIX}: $(SRC_DIR)/pkgc.c - $(CC) -c $(CC_SWITCHES) $(SRC_DIR)/pkgc.c - ${SHLIB_LD} -o pkgc${SHLIB_SUFFIX} pkgc.o ${LIBS} - -pkgd${SHLIB_SUFFIX}: $(SRC_DIR)/pkgd.c - $(CC) -c $(CC_SWITCHES) $(SRC_DIR)/pkgd.c - ${SHLIB_LD} -o pkgd${SHLIB_SUFFIX} pkgd.o ${LIBS} - -pkge${SHLIB_SUFFIX}: $(SRC_DIR)/pkge.c - $(CC) -c $(CC_SWITCHES) $(SRC_DIR)/pkge.c - ${SHLIB_LD} -o pkge${SHLIB_SUFFIX} pkge.o ${LIBS} - -clean: - rm -f *.o *${SHLIB_SUFFIX} config.cache config.log config.status lib.exp - -distclean: clean - rm -f Makefile diff --git a/unix/dltest/README b/unix/dltest/README deleted file mode 100644 index 7ba3f9f..0000000 --- a/unix/dltest/README +++ /dev/null @@ -1,12 +0,0 @@ -This directory contains several files for testing Tcl's dynamic -loading capabilities. If this directory is present and the files -in here have been compiled, then the "load" test will use the shared -libraries present here to run a series of tests. To compile the -shared libraries, first type "./configure". This will read -configuration information created when Tcl was configured and -create Makefile from Makefile.in. Be sure that you have configured -Tcl before configuring here, since information learned during Tcl's -configure is needed here. Then type "make" to create the shared -libraries. - -RCS: @(#) $Id: README,v 1.2 1998/09/14 18:40:18 stanton Exp $ diff --git a/unix/dltest/configure.in b/unix/dltest/configure.in deleted file mode 100644 index bd7b904..0000000 --- a/unix/dltest/configure.in +++ /dev/null @@ -1,33 +0,0 @@ -dnl This file is an input file used by the GNU "autoconf" program to -dnl generate the file "configure", which is run to configure the -dnl Makefile in this directory. -AC_INIT(pkga.c) -# RCS: @(#) $Id: configure.in,v 1.5 1999/04/16 00:48:06 stanton Exp $ - -# Recover information that Tcl computed with its configure script. - -. ../tclConfig.sh - -CC=$TCL_CC -AC_SUBST(CC) -SHLIB_CFLAGS=$TCL_SHLIB_CFLAGS -AC_SUBST(SHLIB_CFLAGS) -EXTRA_CFLAGS=$TCL_EXTRA_CFLAGS -AC_SUBST(EXTRA_CFLAGS) -SHLIB_LD=$TCL_SHLIB_LD -AC_SUBST(SHLIB_LD) -SHLIB_LD_LIBS=$TCL_SHLIB_LD_LIBS -AC_SUBST(SHLIB_LD_LIBS) -SHLIB_SUFFIX=$TCL_SHLIB_SUFFIX -AC_SUBST(SHLIB_SUFFIX) -SHLIB_VERSION=$TCL_SHLIB_VERSION -AC_SUBST(SHLIB_VERSION) -AC_SUBST(TCL_BUILD_STUB_LIB_SPEC) -TCL_LIBS=$TCL_LIBS -AC_SUBST(TCL_LIBS) -TCL_VERSION=$TCL_VERSION -AC_SUBST(TCL_VERSION) -TCL_DBGX=$TCL_DBGX -AC_SUBST(TCL_DBGX) - -AC_OUTPUT(Makefile) diff --git a/unix/dltest/pkga.c b/unix/dltest/pkga.c deleted file mode 100644 index 35bc95c..0000000 --- a/unix/dltest/pkga.c +++ /dev/null @@ -1,130 +0,0 @@ -/* - * pkga.c -- - * - * This file contains a simple Tcl package "pkga" that is intended - * for testing the Tcl dynamic loading facilities. - * - * Copyright (c) 1995 Sun Microsystems, Inc. - * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: pkga.c,v 1.4 2000/04/04 08:06:07 hobbs Exp $ - */ -#include "tcl.h" - -/* - * Prototypes for procedures defined later in this file: - */ - -static int Pkga_EqObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, Tcl_Obj * CONST objv[])); -static int Pkga_QuoteObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, Tcl_Obj * CONST objv[])); - -/* - *---------------------------------------------------------------------- - * - * Pkga_EqObjCmd -- - * - * This procedure is invoked to process the "pkga_eq" Tcl command. - * It expects two arguments and returns 1 if they are the same, - * 0 if they are different. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - -static int -Pkga_EqObjCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj * CONST objv[]; /* Argument objects. */ -{ - int result; - - if (objc != 3) { - Tcl_WrongNumArgs(interp, 1, objv, "string1 string2"); - return TCL_ERROR; - } - - result = !strcmp(Tcl_GetString(objv[1]), Tcl_GetString(objv[2])); - Tcl_SetObjResult(interp, Tcl_NewIntObj(result)); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * Pkga_QuoteObjCmd -- - * - * This procedure is invoked to process the "pkga_quote" Tcl command. - * It expects one argument, which it returns as result. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - -static int -Pkga_QuoteObjCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj * CONST objv[]; /* Argument strings. */ -{ - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "value"); - return TCL_ERROR; - } - Tcl_SetObjResult(interp, objv[1]); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * Pkga_Init -- - * - * This is a package initialization procedure, which is called - * by Tcl when this package is to be added to an interpreter. - * - * Results: - * None. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -Pkga_Init(interp) - Tcl_Interp *interp; /* Interpreter in which the package is - * to be made available. */ -{ - int code; - - if (Tcl_InitStubs(interp, TCL_VERSION, 1) == NULL) { - return TCL_ERROR; - } - code = Tcl_PkgProvide(interp, "Pkga", "1.0"); - if (code != TCL_OK) { - return code; - } - Tcl_CreateObjCommand(interp, "pkga_eq", Pkga_EqObjCmd, - (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); - Tcl_CreateObjCommand(interp, "pkga_quote", Pkga_QuoteObjCmd, - (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); - return TCL_OK; -} diff --git a/unix/dltest/pkgb.c b/unix/dltest/pkgb.c deleted file mode 100644 index 1c43106..0000000 --- a/unix/dltest/pkgb.c +++ /dev/null @@ -1,164 +0,0 @@ -/* - * pkgb.c -- - * - * This file contains a simple Tcl package "pkgb" that is intended - * for testing the Tcl dynamic loading facilities. It can be used - * in both safe and unsafe interpreters. - * - * Copyright (c) 1995 Sun Microsystems, Inc. - * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: pkgb.c,v 1.4 2000/04/04 08:06:07 hobbs Exp $ - */ -#include "tcl.h" - -/* - * Prototypes for procedures defined later in this file: - */ - -static int Pkgb_SubObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, Tcl_Obj * CONST objv[])); -static int Pkgb_UnsafeObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, Tcl_Obj * CONST objv[])); - -/* - *---------------------------------------------------------------------- - * - * Pkgb_SubObjCmd -- - * - * This procedure is invoked to process the "pkgb_sub" Tcl command. - * It expects two arguments and returns their difference. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - -static int -Pkgb_SubObjCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj * CONST objv[]; /* Argument objects. */ -{ - int first, second; - - if (objc != 3) { - Tcl_WrongNumArgs(interp, 1, objv, "num num"); - return TCL_ERROR; - } - if ((Tcl_GetIntFromObj(interp, objv[1], &first) != TCL_OK) - || (Tcl_GetIntFromObj(interp, objv[2], &second) != TCL_OK)) { - return TCL_ERROR; - } - Tcl_SetObjResult(interp, Tcl_NewIntObj(first - second)); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * Pkgb_UnsafeObjCmd -- - * - * This procedure is invoked to process the "pkgb_unsafe" Tcl command. - * It just returns a constant string. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - -static int -Pkgb_UnsafeObjCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj * CONST objv[]; /* Argument objects. */ -{ - Tcl_SetObjResult(interp, Tcl_NewStringObj("unsafe command invoked", -1)); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * Pkgb_Init -- - * - * This is a package initialization procedure, which is called - * by Tcl when this package is to be added to an interpreter. - * - * Results: - * None. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -Pkgb_Init(interp) - Tcl_Interp *interp; /* Interpreter in which the package is - * to be made available. */ -{ - int code; - - if (Tcl_InitStubs(interp, TCL_VERSION, 1) == NULL) { - return TCL_ERROR; - } - code = Tcl_PkgProvide(interp, "Pkgb", "2.3"); - if (code != TCL_OK) { - return code; - } - Tcl_CreateObjCommand(interp, "pkgb_sub", Pkgb_SubObjCmd, - (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); - Tcl_CreateObjCommand(interp, "pkgb_unsafe", Pkgb_UnsafeObjCmd, - (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * Pkgb_SafeInit -- - * - * This is a package initialization procedure, which is called - * by Tcl when this package is to be added to an unsafe interpreter. - * - * Results: - * None. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -Pkgb_SafeInit(interp) - Tcl_Interp *interp; /* Interpreter in which the package is - * to be made available. */ -{ - int code; - - if (Tcl_InitStubs(interp, TCL_VERSION, 1) == NULL) { - return TCL_ERROR; - } - code = Tcl_PkgProvide(interp, "Pkgb", "2.3"); - if (code != TCL_OK) { - return code; - } - Tcl_CreateObjCommand(interp, "pkgb_sub", Pkgb_SubObjCmd, (ClientData) 0, - (Tcl_CmdDeleteProc *) NULL); - return TCL_OK; -} diff --git a/unix/dltest/pkgc.c b/unix/dltest/pkgc.c deleted file mode 100644 index 2d8f576..0000000 --- a/unix/dltest/pkgc.c +++ /dev/null @@ -1,164 +0,0 @@ -/* - * pkgc.c -- - * - * This file contains a simple Tcl package "pkgc" that is intended - * for testing the Tcl dynamic loading facilities. It can be used - * in both safe and unsafe interpreters. - * - * Copyright (c) 1995 Sun Microsystems, Inc. - * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: pkgc.c,v 1.4 2000/04/04 08:06:07 hobbs Exp $ - */ -#include "tcl.h" - -/* - * Prototypes for procedures defined later in this file: - */ - -static int Pkgc_SubObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, Tcl_Obj * CONST objv[])); -static int Pkgc_UnsafeObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, Tcl_Obj * CONST objv[])); - -/* - *---------------------------------------------------------------------- - * - * Pkgc_SubObjCmd -- - * - * This procedure is invoked to process the "pkgc_sub" Tcl command. - * It expects two arguments and returns their difference. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - -static int -Pkgc_SubObjCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj * CONST objv[]; /* Argument objects. */ -{ - int first, second; - - if (objc != 3) { - Tcl_WrongNumArgs(interp, 1, objv, "num num"); - return TCL_ERROR; - } - if ((Tcl_GetIntFromObj(interp, objv[1], &first) != TCL_OK) - || (Tcl_GetIntFromObj(interp, objv[2], &second) != TCL_OK)) { - return TCL_ERROR; - } - Tcl_SetObjResult(interp, Tcl_NewIntObj(first - second)); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * Pkgc_UnsafeCmd -- - * - * This procedure is invoked to process the "pkgc_unsafe" Tcl command. - * It just returns a constant string. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - -static int -Pkgc_UnsafeObjCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj * CONST objv[]; /* Argument objects. */ -{ - Tcl_SetObjResult(interp, Tcl_NewStringObj("unsafe command invoked", -1)); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * Pkgc_Init -- - * - * This is a package initialization procedure, which is called - * by Tcl when this package is to be added to an interpreter. - * - * Results: - * None. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -Pkgc_Init(interp) - Tcl_Interp *interp; /* Interpreter in which the package is - * to be made available. */ -{ - int code; - - if (Tcl_InitStubs(interp, TCL_VERSION, 1) == NULL) { - return TCL_ERROR; - } - code = Tcl_PkgProvide(interp, "Pkgc", "1.7.2"); - if (code != TCL_OK) { - return code; - } - Tcl_CreateObjCommand(interp, "pkgc_sub", Pkgc_SubObjCmd, - (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); - Tcl_CreateObjCommand(interp, "pkgc_unsafe", Pkgc_UnsafeObjCmd, - (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * Pkgc_SafeInit -- - * - * This is a package initialization procedure, which is called - * by Tcl when this package is to be added to an unsafe interpreter. - * - * Results: - * None. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -Pkgc_SafeInit(interp) - Tcl_Interp *interp; /* Interpreter in which the package is - * to be made available. */ -{ - int code; - - if (Tcl_InitStubs(interp, TCL_VERSION, 1) == NULL) { - return TCL_ERROR; - } - code = Tcl_PkgProvide(interp, "Pkgc", "1.7.2"); - if (code != TCL_OK) { - return code; - } - Tcl_CreateObjCommand(interp, "pkgc_sub", Pkgc_SubObjCmd, (ClientData) 0, - (Tcl_CmdDeleteProc *) NULL); - return TCL_OK; -} diff --git a/unix/dltest/pkgd.c b/unix/dltest/pkgd.c deleted file mode 100644 index 7c91405..0000000 --- a/unix/dltest/pkgd.c +++ /dev/null @@ -1,165 +0,0 @@ -/* - * pkgd.c -- - * - * This file contains a simple Tcl package "pkgd" that is intended - * for testing the Tcl dynamic loading facilities. It can be used - * in both safe and unsafe interpreters. - * - * Copyright (c) 1995 Sun Microsystems, Inc. - * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: pkgd.c,v 1.4 2000/04/04 08:06:07 hobbs Exp $ - */ - -#include "tcl.h" - -/* - * Prototypes for procedures defined later in this file: - */ - -static int Pkgd_SubObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, Tcl_Obj * CONST objv[])); -static int Pkgd_UnsafeObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, Tcl_Obj * CONST objv[])); - -/* - *---------------------------------------------------------------------- - * - * Pkgd_SubObjCmd -- - * - * This procedure is invoked to process the "pkgd_sub" Tcl command. - * It expects two arguments and returns their difference. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - -static int -Pkgd_SubObjCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj * CONST objv[]; /* Argument objects. */ -{ - int first, second; - - if (objc != 3) { - Tcl_WrongNumArgs(interp, 1, objv, "num num"); - return TCL_ERROR; - } - if ((Tcl_GetIntFromObj(interp, objv[1], &first) != TCL_OK) - || (Tcl_GetIntFromObj(interp, objv[2], &second) != TCL_OK)) { - return TCL_ERROR; - } - Tcl_SetObjResult(interp, Tcl_NewIntObj(first - second)); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * Pkgd_UnsafeCmd -- - * - * This procedure is invoked to process the "pkgd_unsafe" Tcl command. - * It just returns a constant string. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - -static int -Pkgd_UnsafeObjCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj * CONST objv[]; /* Argument objects. */ -{ - Tcl_SetObjResult(interp, Tcl_NewStringObj("unsafe command invoked", -1)); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * Pkgd_Init -- - * - * This is a package initialization procedure, which is called - * by Tcl when this package is to be added to an interpreter. - * - * Results: - * None. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -Pkgd_Init(interp) - Tcl_Interp *interp; /* Interpreter in which the package is - * to be made available. */ -{ - int code; - - if (Tcl_InitStubs(interp, TCL_VERSION, 1) == NULL) { - return TCL_ERROR; - } - code = Tcl_PkgProvide(interp, "Pkgd", "7.3"); - if (code != TCL_OK) { - return code; - } - Tcl_CreateObjCommand(interp, "pkgd_sub", Pkgd_SubObjCmd, - (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); - Tcl_CreateObjCommand(interp, "pkgd_unsafe", Pkgd_UnsafeObjCmd, - (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * Pkgd_SafeInit -- - * - * This is a package initialization procedure, which is called - * by Tcl when this package is to be added to an unsafe interpreter. - * - * Results: - * None. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -Pkgd_SafeInit(interp) - Tcl_Interp *interp; /* Interpreter in which the package is - * to be made available. */ -{ - int code; - - if (Tcl_InitStubs(interp, TCL_VERSION, 1) == NULL) { - return TCL_ERROR; - } - code = Tcl_PkgProvide(interp, "Pkgd", "7.3"); - if (code != TCL_OK) { - return code; - } - Tcl_CreateObjCommand(interp, "pkgd_sub", Pkgd_SubObjCmd, (ClientData) 0, - (Tcl_CmdDeleteProc *) NULL); - return TCL_OK; -} diff --git a/unix/dltest/pkge.c b/unix/dltest/pkge.c deleted file mode 100644 index d8f71c2..0000000 --- a/unix/dltest/pkge.c +++ /dev/null @@ -1,46 +0,0 @@ -/* - * pkge.c -- - * - * This file contains a simple Tcl package "pkge" that is intended - * for testing the Tcl dynamic loading facilities. Its Init - * procedure returns an error in order to test how this is handled. - * - * Copyright (c) 1995 Sun Microsystems, Inc. - * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: pkge.c,v 1.5 2000/04/04 08:06:07 hobbs Exp $ - */ - -#include "tcl.h" - - -/* - *---------------------------------------------------------------------- - * - * Pkge_Init -- - * - * This is a package initialization procedure, which is called - * by Tcl when this package is to be added to an interpreter. - * - * Results: - * Returns TCL_ERROR and leaves an error message in interp->result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -Pkge_Init(interp) - Tcl_Interp *interp; /* Interpreter in which the package is - * to be made available. */ -{ - static char script[] = "if 44 {open non_existent}"; - if (Tcl_InitStubs(interp, TCL_VERSION, 1) == NULL) { - return TCL_ERROR; - } - return Tcl_Eval(interp, script); -} diff --git a/unix/dltest/pkgf.c b/unix/dltest/pkgf.c deleted file mode 100644 index fc7a936..0000000 --- a/unix/dltest/pkgf.c +++ /dev/null @@ -1,53 +0,0 @@ -/* - * pkgf.c -- - * - * This file contains a simple Tcl package "pkgf" that is intended - * for testing the Tcl dynamic loading facilities. Its Init - * procedure returns an error in order to test how this is handled. - * - * Copyright (c) 1995 Sun Microsystems, Inc. - * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: pkgf.c,v 1.4 1999/04/16 00:48:06 stanton Exp $ - */ -#include "tcl.h" - -/* - * Prototypes for procedures defined later in this file: - */ - -static int Pkgd_SubCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -static int Pkgd_UnsafeCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); - -/* - *---------------------------------------------------------------------- - * - * Pkgf_Init -- - * - * This is a package initialization procedure, which is called - * by Tcl when this package is to be added to an interpreter. - * - * Results: - * Returns TCL_ERROR and leaves an error message in interp->result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -Pkgf_Init(interp) - Tcl_Interp *interp; /* Interpreter in which the package is - * to be made available. */ -{ - static char script[] = "if 44 {open non_existent}"; - if (Tcl_InitStubs(interp, TCL_VERSION, 1) == NULL) { - return TCL_ERROR; - } - return Tcl_Eval(interp, script); -} diff --git a/unix/install-sh b/unix/install-sh deleted file mode 100755 index 0ff4b6a..0000000 --- a/unix/install-sh +++ /dev/null @@ -1,119 +0,0 @@ -#!/bin/sh - -# -# install - install a program, script, or datafile -# This comes from X11R5; it is not part of GNU. -# -# $XConsortium: install.sh,v 1.2 89/12/18 14:47:22 jim Exp $ -# -# This script is compatible with the BSD install script, but was written -# from scratch. -# - - -# set DOITPROG to echo to test this script - -# Don't use :- since 4.3BSD and earlier shells don't like it. -doit="${DOITPROG-}" - - -# put in absolute paths if you don't have them in your path; or use env. vars. - -mvprog="${MVPROG-mv}" -cpprog="${CPPROG-cp}" -chmodprog="${CHMODPROG-chmod}" -chownprog="${CHOWNPROG-chown}" -chgrpprog="${CHGRPPROG-chgrp}" -stripprog="${STRIPPROG-strip}" -rmprog="${RMPROG-rm}" - -instcmd="$mvprog" -chmodcmd="" -chowncmd="" -chgrpcmd="" -stripcmd="" -rmcmd="$rmprog -f" -mvcmd="$mvprog" -src="" -dst="" - -while [ x"$1" != x ]; do - case $1 in - -c) instcmd="$cpprog" - shift - continue;; - - -m) chmodcmd="$chmodprog $2" - shift - shift - continue;; - - -o) chowncmd="$chownprog $2" - shift - shift - continue;; - - -g) chgrpcmd="$chgrpprog $2" - shift - shift - continue;; - - -s) stripcmd="$stripprog" - shift - continue;; - - *) if [ x"$src" = x ] - then - src=$1 - else - dst=$1 - fi - shift - continue;; - esac -done - -if [ x"$src" = x ] -then - echo "install: no input file specified" - exit 1 -fi - -if [ x"$dst" = x ] -then - echo "install: no destination specified" - exit 1 -fi - - -# If destination is a directory, append the input filename; if your system -# does not like double slashes in filenames, you may need to add some logic - -if [ -d $dst ] -then - dst="$dst"/`basename $src` -fi - -# Make a temp file name in the proper directory. - -dstdir=`dirname $dst` -dsttmp=$dstdir/#inst.$$# - -# Move or copy the file name to the temp name - -$doit $instcmd $src $dsttmp - -# and set any options; do chmod last to preserve setuid bits - -if [ x"$chowncmd" != x ]; then $doit $chowncmd $dsttmp; fi -if [ x"$chgrpcmd" != x ]; then $doit $chgrpcmd $dsttmp; fi -if [ x"$stripcmd" != x ]; then $doit $stripcmd $dsttmp; fi -if [ x"$chmodcmd" != x ]; then $doit $chmodcmd $dsttmp; fi - -# Now rename the file to the real destination. - -$doit $rmcmd $dst -$doit $mvcmd $dsttmp $dst - - -exit 0 diff --git a/unix/ldAix b/unix/ldAix deleted file mode 100755 index b554f9d..0000000 --- a/unix/ldAix +++ /dev/null @@ -1,74 +0,0 @@ -#!/bin/sh -# -# ldAix ldCmd ldArg ldArg ... -# -# This shell script provides a wrapper for ld under AIX in order to -# create the .exp file required for linking. Its arguments consist -# of the name and arguments that would normally be provided to the -# ld command. This script extracts the names of the object files -# from the argument list, creates a .exp file describing all of the -# symbols exported by those files, and then invokes "ldCmd" to -# perform the real link. -# -# RCS: @(#) $Id: ldAix,v 1.3 1999/03/10 05:52:52 stanton Exp $ - -# Extract from the arguments the names of all of the object files. - -args=$* -ofiles="" -for i do - x=`echo $i | grep '[^.].o$'` - if test "$x" != ""; then - ofiles="$ofiles $i" - fi -done - -# Extract the name of the object file that we're linking. -outputFile=`echo $args | sed -e 's/.*-o \([^ ]*\).*/\1/'` - -# Create the export file from all of the object files, using nm followed -# by sed editing. Here are some tricky aspects of this: -# -# 1. Nm produces different output under AIX 4.1 than under AIX 3.2.5; -# the following statements handle both versions. -# 2. Use the -g switch to nm instead of -e under 4.1 (this shows just -# externals, not statics; -g isn't available under 3.2.5, though). -# 3. Eliminate lines that end in ":": these are the names of object -# files (relevant in 4.1 only). -# 4. Eliminate entries with the "U" key letter; these are undefined -# symbols (relevant in 4.1 only). -# 5. Eliminate lines that contain the string "0|extern" preceded by space; -# in 3.2.5, these are undefined symbols (address 0). -# 6. Eliminate lines containing the "unamex" symbol. In 3.2.5, these -# are also undefined symbols. -# 7. If a line starts with ".", delete the leading ".", since this will -# just cause confusion later. -# 8. Eliminate everything after the first field in a line, so that we're -# left with just the symbol name. - -nmopts="-g -C" -osver=`uname -v` -if test $osver -eq 3; then - nmopts="-e" -fi -rm -f lib.exp -echo "#! $outputFile" >lib.exp -/usr/ccs/bin/nm $nmopts -h $ofiles | sed -e '/:$/d' -e '/ U /d' -e '/[ ]0|extern/d' -e '/unamex/d' -e 's/^\.//' -e 's/[ |].*//' | sort | uniq >>lib.exp - -# If we're linking a .a file, then link all the objects together into a -# single file "shr.o" and then put that into the archive. Otherwise link -# the object files directly into the .a file. - -outputFile=`echo $args | sed -e 's/.*-o \([^ ]*\).*/\1/'` -noDotA=`echo $outputFile | sed -e '/\.a$/d'` -echo "noDotA=\"$noDotA\"" -if test "$noDotA" = "" ; then - linkArgs=`echo $args | sed -e 's/-o .*\.a /-o shr.o /'` - echo $linkArgs - eval $linkArgs - echo ar cr $outputFile shr.o - ar cr $outputFile shr.o - rm -f shr.o -else - eval $args -fi diff --git a/unix/mkLinks b/unix/mkLinks deleted file mode 100644 index 6df73c8..0000000 --- a/unix/mkLinks +++ /dev/null @@ -1,1011 +0,0 @@ -#!/bin/sh -# This script is invoked when installing manual entries. It generates -# additional links to manual entries, corresponding to the procedure -# and command names described by the manual entry. For example, the -# Tcl manual entry Hash.3 describes procedures Tcl_InitHashTable, -# Tcl_CreateHashEntry, and many more. This script will make hard -# links so that Tcl_InitHashTable.3, Tcl_CreateHashEntry.3, and so -# on all refer to Hash.3 in the installed directory. -# -# Because of the length of command and procedure names, this mechanism -# only works on machines that support file names longer than 14 characters. -# This script checks to see if long file names are supported, and it -# doesn't make any links if they are not. -# -# The script takes one argument, which is the name of the directory -# where the manual entries have been installed. - -if test $# != 1; then - echo "Usage: mkLinks dir" - exit 1 -fi - -cd $1 -echo foo > xyzzyTestingAVeryLongFileName.foo -x=`echo xyzzyTe*` -rm xyzzyTe* -if test "$x" != "xyzzyTestingAVeryLongFileName.foo"; then - exit -fi - -if test -r Access.3; then - rm -f Tcl_Access.3 - rm -f Tcl_Stat.3 - ln Access.3 Tcl_Access.3 - ln Access.3 Tcl_Stat.3 -fi -if test -r AddErrInfo.3; then - rm -f Tcl_AddObjErrorInfo.3 - rm -f Tcl_AddErrorInfo.3 - rm -f Tcl_SetObjErrorCode.3 - rm -f Tcl_SetErrorCode.3 - rm -f Tcl_SetErrorCodeVA.3 - rm -f Tcl_PosixError.3 - rm -f Tcl_LogCommandInfo.3 - ln AddErrInfo.3 Tcl_AddObjErrorInfo.3 - ln AddErrInfo.3 Tcl_AddErrorInfo.3 - ln AddErrInfo.3 Tcl_SetObjErrorCode.3 - ln AddErrInfo.3 Tcl_SetErrorCode.3 - ln AddErrInfo.3 Tcl_SetErrorCodeVA.3 - ln AddErrInfo.3 Tcl_PosixError.3 - ln AddErrInfo.3 Tcl_LogCommandInfo.3 -fi -if test -r Alloc.3; then - rm -f Tcl_Alloc.3 - rm -f Tcl_Free.3 - rm -f Tcl_Realloc.3 - ln Alloc.3 Tcl_Alloc.3 - ln Alloc.3 Tcl_Free.3 - ln Alloc.3 Tcl_Realloc.3 -fi -if test -r AllowExc.3; then - rm -f Tcl_AllowExceptions.3 - ln AllowExc.3 Tcl_AllowExceptions.3 -fi -if test -r AppInit.3; then - rm -f Tcl_AppInit.3 - ln AppInit.3 Tcl_AppInit.3 -fi -if test -r AssocData.3; then - rm -f Tcl_GetAssocData.3 - rm -f Tcl_SetAssocData.3 - rm -f Tcl_DeleteAssocData.3 - ln AssocData.3 Tcl_GetAssocData.3 - ln AssocData.3 Tcl_SetAssocData.3 - ln AssocData.3 Tcl_DeleteAssocData.3 -fi -if test -r Async.3; then - rm -f Tcl_AsyncCreate.3 - rm -f Tcl_AsyncMark.3 - rm -f Tcl_AsyncInvoke.3 - rm -f Tcl_AsyncDelete.3 - rm -f Tcl_AsyncReady.3 - ln Async.3 Tcl_AsyncCreate.3 - ln Async.3 Tcl_AsyncMark.3 - ln Async.3 Tcl_AsyncInvoke.3 - ln Async.3 Tcl_AsyncDelete.3 - ln Async.3 Tcl_AsyncReady.3 -fi -if test -r BackgdErr.3; then - rm -f Tcl_BackgroundError.3 - ln BackgdErr.3 Tcl_BackgroundError.3 -fi -if test -r Backslash.3; then - rm -f Tcl_Backslash.3 - ln Backslash.3 Tcl_Backslash.3 -fi -if test -r BoolObj.3; then - rm -f Tcl_NewBooleanObj.3 - rm -f Tcl_SetBooleanObj.3 - rm -f Tcl_GetBooleanFromObj.3 - ln BoolObj.3 Tcl_NewBooleanObj.3 - ln BoolObj.3 Tcl_SetBooleanObj.3 - ln BoolObj.3 Tcl_GetBooleanFromObj.3 -fi -if test -r ByteArrObj.3; then - rm -f Tcl_NewByteArrayObj.3 - rm -f Tcl_SetByteArrayObj.3 - rm -f Tcl_GetByteArrayFromObj.3 - rm -f Tcl_SetByteArrayLength.3 - ln ByteArrObj.3 Tcl_NewByteArrayObj.3 - ln ByteArrObj.3 Tcl_SetByteArrayObj.3 - ln ByteArrObj.3 Tcl_GetByteArrayFromObj.3 - ln ByteArrObj.3 Tcl_SetByteArrayLength.3 -fi -if test -r CallDel.3; then - rm -f Tcl_CallWhenDeleted.3 - rm -f Tcl_DontCallWhenDeleted.3 - ln CallDel.3 Tcl_CallWhenDeleted.3 - ln CallDel.3 Tcl_DontCallWhenDeleted.3 -fi -if test -r ChnlStack.3; then - rm -f Tcl_StackChannel.3 - rm -f Tcl_UnstackChannel.3 - rm -f Tcl_GetStackedChannel.3 - ln ChnlStack.3 Tcl_StackChannel.3 - ln ChnlStack.3 Tcl_UnstackChannel.3 - ln ChnlStack.3 Tcl_GetStackedChannel.3 -fi -if test -r CmdCmplt.3; then - rm -f Tcl_CommandComplete.3 - ln CmdCmplt.3 Tcl_CommandComplete.3 -fi -if test -r Concat.3; then - rm -f Tcl_Concat.3 - ln Concat.3 Tcl_Concat.3 -fi -if test -r CrtChannel.3; then - rm -f Tcl_CreateChannel.3 - rm -f Tcl_GetChannelInstanceData.3 - rm -f Tcl_GetChannelType.3 - rm -f Tcl_GetChannelName.3 - rm -f Tcl_GetChannelHandle.3 - rm -f Tcl_GetChannelMode.3 - rm -f Tcl_GetChannelBufferSize.3 - rm -f Tcl_SetChannelBufferSize.3 - rm -f Tcl_NotifyChannel.3 - rm -f Tcl_BadChannelOption.3 - rm -f Tcl_ChannelName.3 - rm -f Tcl_ChannelVersion.3 - rm -f Tcl_ChannelBlockModeProc.3 - rm -f Tcl_ChannelCloseProc.3 - rm -f Tcl_ChannelClose2Proc.3 - rm -f Tcl_ChannelInputProc.3 - rm -f Tcl_ChannelOutputProc.3 - rm -f Tcl_ChannelSeekProc.3 - rm -f Tcl_ChannelSetOptionProc.3 - rm -f Tcl_ChannelGetOptionProc.3 - rm -f Tcl_ChannelWatchProc.3 - rm -f Tcl_ChannelGetHandleProc.3 - rm -f Tcl_ChannelFlushProc.3 - rm -f Tcl_ChannelHandlerProc.3 - ln CrtChannel.3 Tcl_CreateChannel.3 - ln CrtChannel.3 Tcl_GetChannelInstanceData.3 - ln CrtChannel.3 Tcl_GetChannelType.3 - ln CrtChannel.3 Tcl_GetChannelName.3 - ln CrtChannel.3 Tcl_GetChannelHandle.3 - ln CrtChannel.3 Tcl_GetChannelMode.3 - ln CrtChannel.3 Tcl_GetChannelBufferSize.3 - ln CrtChannel.3 Tcl_SetChannelBufferSize.3 - ln CrtChannel.3 Tcl_NotifyChannel.3 - ln CrtChannel.3 Tcl_BadChannelOption.3 - ln CrtChannel.3 Tcl_ChannelName.3 - ln CrtChannel.3 Tcl_ChannelVersion.3 - ln CrtChannel.3 Tcl_ChannelBlockModeProc.3 - ln CrtChannel.3 Tcl_ChannelCloseProc.3 - ln CrtChannel.3 Tcl_ChannelClose2Proc.3 - ln CrtChannel.3 Tcl_ChannelInputProc.3 - ln CrtChannel.3 Tcl_ChannelOutputProc.3 - ln CrtChannel.3 Tcl_ChannelSeekProc.3 - ln CrtChannel.3 Tcl_ChannelSetOptionProc.3 - ln CrtChannel.3 Tcl_ChannelGetOptionProc.3 - ln CrtChannel.3 Tcl_ChannelWatchProc.3 - ln CrtChannel.3 Tcl_ChannelGetHandleProc.3 - ln CrtChannel.3 Tcl_ChannelFlushProc.3 - ln CrtChannel.3 Tcl_ChannelHandlerProc.3 -fi -if test -r CrtChnlHdlr.3; then - rm -f Tcl_CreateChannelHandler.3 - rm -f Tcl_DeleteChannelHandler.3 - ln CrtChnlHdlr.3 Tcl_CreateChannelHandler.3 - ln CrtChnlHdlr.3 Tcl_DeleteChannelHandler.3 -fi -if test -r CrtCloseHdlr.3; then - rm -f Tcl_CreateCloseHandler.3 - rm -f Tcl_DeleteCloseHandler.3 - ln CrtCloseHdlr.3 Tcl_CreateCloseHandler.3 - ln CrtCloseHdlr.3 Tcl_DeleteCloseHandler.3 -fi -if test -r CrtCommand.3; then - rm -f Tcl_CreateCommand.3 - ln CrtCommand.3 Tcl_CreateCommand.3 -fi -if test -r CrtFileHdlr.3; then - rm -f Tcl_CreateFileHandler.3 - rm -f Tcl_DeleteFileHandler.3 - ln CrtFileHdlr.3 Tcl_CreateFileHandler.3 - ln CrtFileHdlr.3 Tcl_DeleteFileHandler.3 -fi -if test -r CrtInterp.3; then - rm -f Tcl_CreateInterp.3 - rm -f Tcl_DeleteInterp.3 - rm -f Tcl_InterpDeleted.3 - ln CrtInterp.3 Tcl_CreateInterp.3 - ln CrtInterp.3 Tcl_DeleteInterp.3 - ln CrtInterp.3 Tcl_InterpDeleted.3 -fi -if test -r CrtMathFnc.3; then - rm -f Tcl_CreateMathFunc.3 - ln CrtMathFnc.3 Tcl_CreateMathFunc.3 -fi -if test -r CrtObjCmd.3; then - rm -f Tcl_CreateObjCommand.3 - rm -f Tcl_DeleteCommand.3 - rm -f Tcl_DeleteCommandFromToken.3 - rm -f Tcl_GetCommandInfo.3 - rm -f Tcl_SetCommandInfo.3 - rm -f Tcl_GetCommandName.3 - ln CrtObjCmd.3 Tcl_CreateObjCommand.3 - ln CrtObjCmd.3 Tcl_DeleteCommand.3 - ln CrtObjCmd.3 Tcl_DeleteCommandFromToken.3 - ln CrtObjCmd.3 Tcl_GetCommandInfo.3 - ln CrtObjCmd.3 Tcl_SetCommandInfo.3 - ln CrtObjCmd.3 Tcl_GetCommandName.3 -fi -if test -r CrtSlave.3; then - rm -f Tcl_IsSafe.3 - rm -f Tcl_MakeSafe.3 - rm -f Tcl_CreateSlave.3 - rm -f Tcl_GetSlave.3 - rm -f Tcl_GetMaster.3 - rm -f Tcl_GetInterpPath.3 - rm -f Tcl_CreateAlias.3 - rm -f Tcl_CreateAliasObj.3 - rm -f Tcl_GetAlias.3 - rm -f Tcl_GetAliasObj.3 - rm -f Tcl_ExposeCommand.3 - rm -f Tcl_HideCommand.3 - ln CrtSlave.3 Tcl_IsSafe.3 - ln CrtSlave.3 Tcl_MakeSafe.3 - ln CrtSlave.3 Tcl_CreateSlave.3 - ln CrtSlave.3 Tcl_GetSlave.3 - ln CrtSlave.3 Tcl_GetMaster.3 - ln CrtSlave.3 Tcl_GetInterpPath.3 - ln CrtSlave.3 Tcl_CreateAlias.3 - ln CrtSlave.3 Tcl_CreateAliasObj.3 - ln CrtSlave.3 Tcl_GetAlias.3 - ln CrtSlave.3 Tcl_GetAliasObj.3 - ln CrtSlave.3 Tcl_ExposeCommand.3 - ln CrtSlave.3 Tcl_HideCommand.3 -fi -if test -r CrtTimerHdlr.3; then - rm -f Tcl_CreateTimerHandler.3 - rm -f Tcl_DeleteTimerHandler.3 - ln CrtTimerHdlr.3 Tcl_CreateTimerHandler.3 - ln CrtTimerHdlr.3 Tcl_DeleteTimerHandler.3 -fi -if test -r CrtTrace.3; then - rm -f Tcl_CreateTrace.3 - rm -f Tcl_DeleteTrace.3 - ln CrtTrace.3 Tcl_CreateTrace.3 - ln CrtTrace.3 Tcl_DeleteTrace.3 -fi -if test -r DString.3; then - rm -f Tcl_DStringInit.3 - rm -f Tcl_DStringAppend.3 - rm -f Tcl_DStringAppendElement.3 - rm -f Tcl_DStringStartSublist.3 - rm -f Tcl_DStringEndSublist.3 - rm -f Tcl_DStringLength.3 - rm -f Tcl_DStringValue.3 - rm -f Tcl_DStringSetLength.3 - rm -f Tcl_DStringFree.3 - rm -f Tcl_DStringResult.3 - rm -f Tcl_DStringGetResult.3 - ln DString.3 Tcl_DStringInit.3 - ln DString.3 Tcl_DStringAppend.3 - ln DString.3 Tcl_DStringAppendElement.3 - ln DString.3 Tcl_DStringStartSublist.3 - ln DString.3 Tcl_DStringEndSublist.3 - ln DString.3 Tcl_DStringLength.3 - ln DString.3 Tcl_DStringValue.3 - ln DString.3 Tcl_DStringSetLength.3 - ln DString.3 Tcl_DStringFree.3 - ln DString.3 Tcl_DStringResult.3 - ln DString.3 Tcl_DStringGetResult.3 -fi -if test -r DetachPids.3; then - rm -f Tcl_DetachPids.3 - rm -f Tcl_ReapDetachedProcs.3 - ln DetachPids.3 Tcl_DetachPids.3 - ln DetachPids.3 Tcl_ReapDetachedProcs.3 -fi -if test -r DoOneEvent.3; then - rm -f Tcl_DoOneEvent.3 - ln DoOneEvent.3 Tcl_DoOneEvent.3 -fi -if test -r DoWhenIdle.3; then - rm -f Tcl_DoWhenIdle.3 - rm -f Tcl_CancelIdleCall.3 - ln DoWhenIdle.3 Tcl_DoWhenIdle.3 - ln DoWhenIdle.3 Tcl_CancelIdleCall.3 -fi -if test -r DoubleObj.3; then - rm -f Tcl_NewDoubleObj.3 - rm -f Tcl_SetDoubleObj.3 - rm -f Tcl_GetDoubleFromObj.3 - ln DoubleObj.3 Tcl_NewDoubleObj.3 - ln DoubleObj.3 Tcl_SetDoubleObj.3 - ln DoubleObj.3 Tcl_GetDoubleFromObj.3 -fi -if test -r DumpActiveMemory.3; then - rm -f Tcl_DumpActiveMemory.3 - rm -f Tcl_InitMemory.3 - rm -f Tcl_ValidateAllMemory.3 - ln DumpActiveMemory.3 Tcl_DumpActiveMemory.3 - ln DumpActiveMemory.3 Tcl_InitMemory.3 - ln DumpActiveMemory.3 Tcl_ValidateAllMemory.3 -fi -if test -r Encoding.3; then - rm -f Tcl_GetEncoding.3 - rm -f Tcl_FreeEncoding.3 - rm -f Tcl_ExternalToUtfDString.3 - rm -f Tcl_ExternalToUtf.3 - rm -f Tcl_UtfToExternalDString.3 - rm -f Tcl_UtfToExternal.3 - rm -f Tcl_WinTCharToUtf.3 - rm -f Tcl_WinUtfToTChar.3 - rm -f Tcl_GetEncodingName.3 - rm -f Tcl_SetSystemEncoding.3 - rm -f Tcl_GetEncodingNames.3 - rm -f Tcl_CreateEncoding.3 - rm -f Tcl_GetDefaultEncodingDir.3 - rm -f Tcl_SetDefaultEncodingDir.3 - ln Encoding.3 Tcl_GetEncoding.3 - ln Encoding.3 Tcl_FreeEncoding.3 - ln Encoding.3 Tcl_ExternalToUtfDString.3 - ln Encoding.3 Tcl_ExternalToUtf.3 - ln Encoding.3 Tcl_UtfToExternalDString.3 - ln Encoding.3 Tcl_UtfToExternal.3 - ln Encoding.3 Tcl_WinTCharToUtf.3 - ln Encoding.3 Tcl_WinUtfToTChar.3 - ln Encoding.3 Tcl_GetEncodingName.3 - ln Encoding.3 Tcl_SetSystemEncoding.3 - ln Encoding.3 Tcl_GetEncodingNames.3 - ln Encoding.3 Tcl_CreateEncoding.3 - ln Encoding.3 Tcl_GetDefaultEncodingDir.3 - ln Encoding.3 Tcl_SetDefaultEncodingDir.3 -fi -if test -r Eval.3; then - rm -f Tcl_EvalObjEx.3 - rm -f Tcl_EvalFile.3 - rm -f Tcl_EvalObjv.3 - rm -f Tcl_Eval.3 - rm -f Tcl_EvalEx.3 - rm -f Tcl_GlobalEval.3 - rm -f Tcl_GlobalEvalObj.3 - rm -f Tcl_VarEval.3 - rm -f Tcl_VarEvalVA.3 - ln Eval.3 Tcl_EvalObjEx.3 - ln Eval.3 Tcl_EvalFile.3 - ln Eval.3 Tcl_EvalObjv.3 - ln Eval.3 Tcl_Eval.3 - ln Eval.3 Tcl_EvalEx.3 - ln Eval.3 Tcl_GlobalEval.3 - ln Eval.3 Tcl_GlobalEvalObj.3 - ln Eval.3 Tcl_VarEval.3 - ln Eval.3 Tcl_VarEvalVA.3 -fi -if test -r Exit.3; then - rm -f Tcl_Exit.3 - rm -f Tcl_Finalize.3 - rm -f Tcl_CreateExitHandler.3 - rm -f Tcl_DeleteExitHandler.3 - rm -f Tcl_ExitThread.3 - rm -f Tcl_FinalizeThread.3 - rm -f Tcl_CreateThreadExitHandler.3 - rm -f Tcl_DeleteThreadExitHandler.3 - ln Exit.3 Tcl_Exit.3 - ln Exit.3 Tcl_Finalize.3 - ln Exit.3 Tcl_CreateExitHandler.3 - ln Exit.3 Tcl_DeleteExitHandler.3 - ln Exit.3 Tcl_ExitThread.3 - ln Exit.3 Tcl_FinalizeThread.3 - ln Exit.3 Tcl_CreateThreadExitHandler.3 - ln Exit.3 Tcl_DeleteThreadExitHandler.3 -fi -if test -r ExprLong.3; then - rm -f Tcl_ExprLong.3 - rm -f Tcl_ExprDouble.3 - rm -f Tcl_ExprBoolean.3 - rm -f Tcl_ExprString.3 - ln ExprLong.3 Tcl_ExprLong.3 - ln ExprLong.3 Tcl_ExprDouble.3 - ln ExprLong.3 Tcl_ExprBoolean.3 - ln ExprLong.3 Tcl_ExprString.3 -fi -if test -r ExprLongObj.3; then - rm -f Tcl_ExprLongObj.3 - rm -f Tcl_ExprDoubleObj.3 - rm -f Tcl_ExprBooleanObj.3 - rm -f Tcl_ExprObj.3 - ln ExprLongObj.3 Tcl_ExprLongObj.3 - ln ExprLongObj.3 Tcl_ExprDoubleObj.3 - ln ExprLongObj.3 Tcl_ExprBooleanObj.3 - ln ExprLongObj.3 Tcl_ExprObj.3 -fi -if test -r FindExec.3; then - rm -f Tcl_FindExecutable.3 - rm -f Tcl_GetNameOfExecutable.3 - ln FindExec.3 Tcl_FindExecutable.3 - ln FindExec.3 Tcl_GetNameOfExecutable.3 -fi -if test -r GetCwd.3; then - rm -f Tcl_GetCwd.3 - rm -f Tcl_Chdir.3 - ln GetCwd.3 Tcl_GetCwd.3 - ln GetCwd.3 Tcl_Chdir.3 -fi -if test -r GetHostName.3; then - rm -f Tcl_GetHostName.3 - ln GetHostName.3 Tcl_GetHostName.3 -fi -if test -r GetIndex.3; then - rm -f Tcl_GetIndexFromObj.3 - rm -f Tcl_GetIndexFromObjStruct.3 - ln GetIndex.3 Tcl_GetIndexFromObj.3 - ln GetIndex.3 Tcl_GetIndexFromObjStruct.3 -fi -if test -r GetInt.3; then - rm -f Tcl_GetInt.3 - rm -f Tcl_GetDouble.3 - rm -f Tcl_GetBoolean.3 - ln GetInt.3 Tcl_GetInt.3 - ln GetInt.3 Tcl_GetDouble.3 - ln GetInt.3 Tcl_GetBoolean.3 -fi -if test -r GetOpnFl.3; then - rm -f Tcl_GetOpenFile.3 - ln GetOpnFl.3 Tcl_GetOpenFile.3 -fi -if test -r GetStdChan.3; then - rm -f Tcl_GetStdChannel.3 - rm -f Tcl_SetStdChannel.3 - ln GetStdChan.3 Tcl_GetStdChannel.3 - ln GetStdChan.3 Tcl_SetStdChannel.3 -fi -if test -r GetVersion.3; then - rm -f Tcl_GetVersion.3 - ln GetVersion.3 Tcl_GetVersion.3 -fi -if test -r Hash.3; then - rm -f Tcl_InitHashTable.3 - rm -f Tcl_DeleteHashTable.3 - rm -f Tcl_CreateHashEntry.3 - rm -f Tcl_DeleteHashEntry.3 - rm -f Tcl_FindHashEntry.3 - rm -f Tcl_GetHashValue.3 - rm -f Tcl_SetHashValue.3 - rm -f Tcl_GetHashKey.3 - rm -f Tcl_FirstHashEntry.3 - rm -f Tcl_NextHashEntry.3 - rm -f Tcl_HashStats.3 - ln Hash.3 Tcl_InitHashTable.3 - ln Hash.3 Tcl_DeleteHashTable.3 - ln Hash.3 Tcl_CreateHashEntry.3 - ln Hash.3 Tcl_DeleteHashEntry.3 - ln Hash.3 Tcl_FindHashEntry.3 - ln Hash.3 Tcl_GetHashValue.3 - ln Hash.3 Tcl_SetHashValue.3 - ln Hash.3 Tcl_GetHashKey.3 - ln Hash.3 Tcl_FirstHashEntry.3 - ln Hash.3 Tcl_NextHashEntry.3 - ln Hash.3 Tcl_HashStats.3 -fi -if test -r Init.3; then - rm -f Tcl_Init.3 - ln Init.3 Tcl_Init.3 -fi -if test -r InitStubs.3; then - rm -f Tcl_InitStubs.3 - ln InitStubs.3 Tcl_InitStubs.3 -fi -if test -r IntObj.3; then - rm -f Tcl_NewIntObj.3 - rm -f Tcl_NewLongObj.3 - rm -f Tcl_SetIntObj.3 - rm -f Tcl_SetLongObj.3 - rm -f Tcl_GetIntFromObj.3 - rm -f Tcl_GetLongFromObj.3 - ln IntObj.3 Tcl_NewIntObj.3 - ln IntObj.3 Tcl_NewLongObj.3 - ln IntObj.3 Tcl_SetIntObj.3 - ln IntObj.3 Tcl_SetLongObj.3 - ln IntObj.3 Tcl_GetIntFromObj.3 - ln IntObj.3 Tcl_GetLongFromObj.3 -fi -if test -r Interp.3; then - rm -f Tcl_Interp.3 - ln Interp.3 Tcl_Interp.3 -fi -if test -r LinkVar.3; then - rm -f Tcl_LinkVar.3 - rm -f Tcl_UnlinkVar.3 - rm -f Tcl_UpdateLinkedVar.3 - ln LinkVar.3 Tcl_LinkVar.3 - ln LinkVar.3 Tcl_UnlinkVar.3 - ln LinkVar.3 Tcl_UpdateLinkedVar.3 -fi -if test -r ListObj.3; then - rm -f Tcl_ListObjAppendList.3 - rm -f Tcl_ListObjAppendElement.3 - rm -f Tcl_NewListObj.3 - rm -f Tcl_SetListObj.3 - rm -f Tcl_ListObjGetElements.3 - rm -f Tcl_ListObjLength.3 - rm -f Tcl_ListObjIndex.3 - rm -f Tcl_ListObjReplace.3 - ln ListObj.3 Tcl_ListObjAppendList.3 - ln ListObj.3 Tcl_ListObjAppendElement.3 - ln ListObj.3 Tcl_NewListObj.3 - ln ListObj.3 Tcl_SetListObj.3 - ln ListObj.3 Tcl_ListObjGetElements.3 - ln ListObj.3 Tcl_ListObjLength.3 - ln ListObj.3 Tcl_ListObjIndex.3 - ln ListObj.3 Tcl_ListObjReplace.3 -fi -if test -r Notifier.3; then - rm -f Tcl_CreateEventSource.3 - rm -f Tcl_DeleteEventSource.3 - rm -f Tcl_SetMaxBlockTime.3 - rm -f Tcl_QueueEvent.3 - rm -f Tcl_ThreadQueueEvent.3 - rm -f Tcl_ThreadAlert.3 - rm -f Tcl_GetCurrentThread.3 - rm -f Tcl_DeleteEvents.3 - rm -f Tcl_InitNotifier.3 - rm -f Tcl_FinalizeNotifier.3 - rm -f Tcl_WaitForEvent.3 - rm -f Tcl_AlertNotifier.3 - rm -f Tcl_SetTimer.3 - rm -f Tcl_ServiceAll.3 - rm -f Tcl_ServiceEvent.3 - rm -f Tcl_GetServiceMode.3 - rm -f Tcl_SetServiceMode.3 - ln Notifier.3 Tcl_CreateEventSource.3 - ln Notifier.3 Tcl_DeleteEventSource.3 - ln Notifier.3 Tcl_SetMaxBlockTime.3 - ln Notifier.3 Tcl_QueueEvent.3 - ln Notifier.3 Tcl_ThreadQueueEvent.3 - ln Notifier.3 Tcl_ThreadAlert.3 - ln Notifier.3 Tcl_GetCurrentThread.3 - ln Notifier.3 Tcl_DeleteEvents.3 - ln Notifier.3 Tcl_InitNotifier.3 - ln Notifier.3 Tcl_FinalizeNotifier.3 - ln Notifier.3 Tcl_WaitForEvent.3 - ln Notifier.3 Tcl_AlertNotifier.3 - ln Notifier.3 Tcl_SetTimer.3 - ln Notifier.3 Tcl_ServiceAll.3 - ln Notifier.3 Tcl_ServiceEvent.3 - ln Notifier.3 Tcl_GetServiceMode.3 - ln Notifier.3 Tcl_SetServiceMode.3 -fi -if test -r Object.3; then - rm -f Tcl_NewObj.3 - rm -f Tcl_DuplicateObj.3 - rm -f Tcl_IncrRefCount.3 - rm -f Tcl_DecrRefCount.3 - rm -f Tcl_IsShared.3 - rm -f Tcl_InvalidateStringRep.3 - ln Object.3 Tcl_NewObj.3 - ln Object.3 Tcl_DuplicateObj.3 - ln Object.3 Tcl_IncrRefCount.3 - ln Object.3 Tcl_DecrRefCount.3 - ln Object.3 Tcl_IsShared.3 - ln Object.3 Tcl_InvalidateStringRep.3 -fi -if test -r ObjectType.3; then - rm -f Tcl_RegisterObjType.3 - rm -f Tcl_GetObjType.3 - rm -f Tcl_AppendAllObjTypes.3 - rm -f Tcl_ConvertToType.3 - ln ObjectType.3 Tcl_RegisterObjType.3 - ln ObjectType.3 Tcl_GetObjType.3 - ln ObjectType.3 Tcl_AppendAllObjTypes.3 - ln ObjectType.3 Tcl_ConvertToType.3 -fi -if test -r OpenFileChnl.3; then - rm -f Tcl_OpenFileChannel.3 - rm -f Tcl_OpenCommandChannel.3 - rm -f Tcl_MakeFileChannel.3 - rm -f Tcl_GetChannel.3 - rm -f Tcl_GetChannelNames.3 - rm -f Tcl_GetChannelNamesEx.3 - rm -f Tcl_RegisterChannel.3 - rm -f Tcl_UnregisterChannel.3 - rm -f Tcl_Close.3 - rm -f Tcl_ReadChars.3 - rm -f Tcl_Read.3 - rm -f Tcl_GetsObj.3 - rm -f Tcl_Gets.3 - rm -f Tcl_WriteObj.3 - rm -f Tcl_WriteChars.3 - rm -f Tcl_Write.3 - rm -f Tcl_Flush.3 - rm -f Tcl_Seek.3 - rm -f Tcl_Tell.3 - rm -f Tcl_GetChannelOption.3 - rm -f Tcl_SetChannelOption.3 - rm -f Tcl_Eof.3 - rm -f Tcl_InputBlocked.3 - rm -f Tcl_InputBuffered.3 - rm -f Tcl_Ungets.3 - ln OpenFileChnl.3 Tcl_OpenFileChannel.3 - ln OpenFileChnl.3 Tcl_OpenCommandChannel.3 - ln OpenFileChnl.3 Tcl_MakeFileChannel.3 - ln OpenFileChnl.3 Tcl_GetChannel.3 - ln OpenFileChnl.3 Tcl_GetChannelNames.3 - ln OpenFileChnl.3 Tcl_GetChannelNamesEx.3 - ln OpenFileChnl.3 Tcl_RegisterChannel.3 - ln OpenFileChnl.3 Tcl_UnregisterChannel.3 - ln OpenFileChnl.3 Tcl_Close.3 - ln OpenFileChnl.3 Tcl_ReadChars.3 - ln OpenFileChnl.3 Tcl_Read.3 - ln OpenFileChnl.3 Tcl_GetsObj.3 - ln OpenFileChnl.3 Tcl_Gets.3 - ln OpenFileChnl.3 Tcl_WriteObj.3 - ln OpenFileChnl.3 Tcl_WriteChars.3 - ln OpenFileChnl.3 Tcl_Write.3 - ln OpenFileChnl.3 Tcl_Flush.3 - ln OpenFileChnl.3 Tcl_Seek.3 - ln OpenFileChnl.3 Tcl_Tell.3 - ln OpenFileChnl.3 Tcl_GetChannelOption.3 - ln OpenFileChnl.3 Tcl_SetChannelOption.3 - ln OpenFileChnl.3 Tcl_Eof.3 - ln OpenFileChnl.3 Tcl_InputBlocked.3 - ln OpenFileChnl.3 Tcl_InputBuffered.3 - ln OpenFileChnl.3 Tcl_Ungets.3 -fi -if test -r OpenTcp.3; then - rm -f Tcl_OpenTcpClient.3 - rm -f Tcl_MakeTcpClientChannel.3 - rm -f Tcl_OpenTcpServer.3 - ln OpenTcp.3 Tcl_OpenTcpClient.3 - ln OpenTcp.3 Tcl_MakeTcpClientChannel.3 - ln OpenTcp.3 Tcl_OpenTcpServer.3 -fi -if test -r ParseCmd.3; then - rm -f Tcl_ParseCommand.3 - rm -f Tcl_ParseExpr.3 - rm -f Tcl_ParseBraces.3 - rm -f Tcl_ParseQuotedString.3 - rm -f Tcl_ParseVarName.3 - rm -f Tcl_ParseVar.3 - rm -f Tcl_FreeParse.3 - rm -f Tcl_EvalTokens.3 - ln ParseCmd.3 Tcl_ParseCommand.3 - ln ParseCmd.3 Tcl_ParseExpr.3 - ln ParseCmd.3 Tcl_ParseBraces.3 - ln ParseCmd.3 Tcl_ParseQuotedString.3 - ln ParseCmd.3 Tcl_ParseVarName.3 - ln ParseCmd.3 Tcl_ParseVar.3 - ln ParseCmd.3 Tcl_FreeParse.3 - ln ParseCmd.3 Tcl_EvalTokens.3 -fi -if test -r PkgRequire.3; then - rm -f Tcl_PkgRequire.3 - rm -f Tcl_PkgRequireEx.3 - rm -f Tcl_PkgPresent.3 - rm -f Tcl_PkgPresentEx.3 - rm -f Tcl_PkgProvide.3 - rm -f Tcl_PkgProvideEx.3 - ln PkgRequire.3 Tcl_PkgRequire.3 - ln PkgRequire.3 Tcl_PkgRequireEx.3 - ln PkgRequire.3 Tcl_PkgPresent.3 - ln PkgRequire.3 Tcl_PkgPresentEx.3 - ln PkgRequire.3 Tcl_PkgProvide.3 - ln PkgRequire.3 Tcl_PkgProvideEx.3 -fi -if test -r Preserve.3; then - rm -f Tcl_Preserve.3 - rm -f Tcl_Release.3 - rm -f Tcl_EventuallyFree.3 - ln Preserve.3 Tcl_Preserve.3 - ln Preserve.3 Tcl_Release.3 - ln Preserve.3 Tcl_EventuallyFree.3 -fi -if test -r PrintDbl.3; then - rm -f Tcl_PrintDouble.3 - ln PrintDbl.3 Tcl_PrintDouble.3 -fi -if test -r RecEvalObj.3; then - rm -f Tcl_RecordAndEvalObj.3 - ln RecEvalObj.3 Tcl_RecordAndEvalObj.3 -fi -if test -r RecordEval.3; then - rm -f Tcl_RecordAndEval.3 - ln RecordEval.3 Tcl_RecordAndEval.3 -fi -if test -r RegExp.3; then - rm -f Tcl_RegExpMatch.3 - rm -f Tcl_RegExpCompile.3 - rm -f Tcl_RegExpExec.3 - rm -f Tcl_RegExpRange.3 - rm -f Tcl_GetRegExpFromObj.3 - rm -f Tcl_RegExpMatchObj.3 - rm -f Tcl_RegExpExecObj.3 - rm -f Tcl_RegExpGetInfo.3 - ln RegExp.3 Tcl_RegExpMatch.3 - ln RegExp.3 Tcl_RegExpCompile.3 - ln RegExp.3 Tcl_RegExpExec.3 - ln RegExp.3 Tcl_RegExpRange.3 - ln RegExp.3 Tcl_GetRegExpFromObj.3 - ln RegExp.3 Tcl_RegExpMatchObj.3 - ln RegExp.3 Tcl_RegExpExecObj.3 - ln RegExp.3 Tcl_RegExpGetInfo.3 -fi -if test -r SaveResult.3; then - rm -f Tcl_SaveResult.3 - rm -f Tcl_RestoreResult.3 - rm -f Tcl_DiscardResult.3 - ln SaveResult.3 Tcl_SaveResult.3 - ln SaveResult.3 Tcl_RestoreResult.3 - ln SaveResult.3 Tcl_DiscardResult.3 -fi -if test -r SetErrno.3; then - rm -f Tcl_SetErrno.3 - rm -f Tcl_GetErrno.3 - rm -f Tcl_ErrnoId.3 - rm -f Tcl_ErrnoMsg.3 - ln SetErrno.3 Tcl_SetErrno.3 - ln SetErrno.3 Tcl_GetErrno.3 - ln SetErrno.3 Tcl_ErrnoId.3 - ln SetErrno.3 Tcl_ErrnoMsg.3 -fi -if test -r SetRecLmt.3; then - rm -f Tcl_SetRecursionLimit.3 - ln SetRecLmt.3 Tcl_SetRecursionLimit.3 -fi -if test -r SetResult.3; then - rm -f Tcl_SetObjResult.3 - rm -f Tcl_GetObjResult.3 - rm -f Tcl_SetResult.3 - rm -f Tcl_GetStringResult.3 - rm -f Tcl_AppendResult.3 - rm -f Tcl_AppendResultVA.3 - rm -f Tcl_AppendElement.3 - rm -f Tcl_ResetResult.3 - rm -f Tcl_FreeResult.3 - ln SetResult.3 Tcl_SetObjResult.3 - ln SetResult.3 Tcl_GetObjResult.3 - ln SetResult.3 Tcl_SetResult.3 - ln SetResult.3 Tcl_GetStringResult.3 - ln SetResult.3 Tcl_AppendResult.3 - ln SetResult.3 Tcl_AppendResultVA.3 - ln SetResult.3 Tcl_AppendElement.3 - ln SetResult.3 Tcl_ResetResult.3 - ln SetResult.3 Tcl_FreeResult.3 -fi -if test -r SetVar.3; then - rm -f Tcl_SetVar2Ex.3 - rm -f Tcl_SetVar.3 - rm -f Tcl_SetVar2.3 - rm -f Tcl_ObjSetVar2.3 - rm -f Tcl_GetVar2Ex.3 - rm -f Tcl_GetVar.3 - rm -f Tcl_GetVar2.3 - rm -f Tcl_ObjGetVar2.3 - rm -f Tcl_UnsetVar.3 - rm -f Tcl_UnsetVar2.3 - ln SetVar.3 Tcl_SetVar2Ex.3 - ln SetVar.3 Tcl_SetVar.3 - ln SetVar.3 Tcl_SetVar2.3 - ln SetVar.3 Tcl_ObjSetVar2.3 - ln SetVar.3 Tcl_GetVar2Ex.3 - ln SetVar.3 Tcl_GetVar.3 - ln SetVar.3 Tcl_GetVar2.3 - ln SetVar.3 Tcl_ObjGetVar2.3 - ln SetVar.3 Tcl_UnsetVar.3 - ln SetVar.3 Tcl_UnsetVar2.3 -fi -if test -r Sleep.3; then - rm -f Tcl_Sleep.3 - ln Sleep.3 Tcl_Sleep.3 -fi -if test -r SourceRCFile.3; then - rm -f Tcl_SourceRCFile.3 - ln SourceRCFile.3 Tcl_SourceRCFile.3 -fi -if test -r SplitList.3; then - rm -f Tcl_SplitList.3 - rm -f Tcl_Merge.3 - rm -f Tcl_ScanElement.3 - rm -f Tcl_ConvertElement.3 - rm -f Tcl_ScanCountedElement.3 - rm -f Tcl_ConvertCountedElement.3 - ln SplitList.3 Tcl_SplitList.3 - ln SplitList.3 Tcl_Merge.3 - ln SplitList.3 Tcl_ScanElement.3 - ln SplitList.3 Tcl_ConvertElement.3 - ln SplitList.3 Tcl_ScanCountedElement.3 - ln SplitList.3 Tcl_ConvertCountedElement.3 -fi -if test -r SplitPath.3; then - rm -f Tcl_SplitPath.3 - rm -f Tcl_JoinPath.3 - rm -f Tcl_GetPathType.3 - ln SplitPath.3 Tcl_SplitPath.3 - ln SplitPath.3 Tcl_JoinPath.3 - ln SplitPath.3 Tcl_GetPathType.3 -fi -if test -r StaticPkg.3; then - rm -f Tcl_StaticPackage.3 - ln StaticPkg.3 Tcl_StaticPackage.3 -fi -if test -r StrMatch.3; then - rm -f Tcl_StringMatch.3 - rm -f Tcl_StringCaseMatch.3 - ln StrMatch.3 Tcl_StringMatch.3 - ln StrMatch.3 Tcl_StringCaseMatch.3 -fi -if test -r StringObj.3; then - rm -f Tcl_NewStringObj.3 - rm -f Tcl_NewUnicodeObj.3 - rm -f Tcl_SetStringObj.3 - rm -f Tcl_SetUnicodeObj.3 - rm -f Tcl_GetStringFromObj.3 - rm -f Tcl_GetString.3 - rm -f Tcl_GetUnicode.3 - rm -f Tcl_GetUniChar.3 - rm -f Tcl_GetCharLength.3 - rm -f Tcl_GetRange.3 - rm -f Tcl_AppendToObj.3 - rm -f Tcl_AppendUnicodeToObj.3 - rm -f Tcl_AppendStringsToObj.3 - rm -f Tcl_AppendStringsToObjVA.3 - rm -f Tcl_AppendObjToObj.3 - rm -f Tcl_SetObjLength.3 - rm -f Tcl_ConcatObj.3 - ln StringObj.3 Tcl_NewStringObj.3 - ln StringObj.3 Tcl_NewUnicodeObj.3 - ln StringObj.3 Tcl_SetStringObj.3 - ln StringObj.3 Tcl_SetUnicodeObj.3 - ln StringObj.3 Tcl_GetStringFromObj.3 - ln StringObj.3 Tcl_GetString.3 - ln StringObj.3 Tcl_GetUnicode.3 - ln StringObj.3 Tcl_GetUniChar.3 - ln StringObj.3 Tcl_GetCharLength.3 - ln StringObj.3 Tcl_GetRange.3 - ln StringObj.3 Tcl_AppendToObj.3 - ln StringObj.3 Tcl_AppendUnicodeToObj.3 - ln StringObj.3 Tcl_AppendStringsToObj.3 - ln StringObj.3 Tcl_AppendStringsToObjVA.3 - ln StringObj.3 Tcl_AppendObjToObj.3 - ln StringObj.3 Tcl_SetObjLength.3 - ln StringObj.3 Tcl_ConcatObj.3 -fi -if test -r Thread.3; then - rm -f Tcl_ConditionNotify.3 - rm -f Tcl_ConditionWait.3 - rm -f Tcl_ConditionFinalize.3 - rm -f Tcl_GetThreadData.3 - rm -f Tcl_MutexLock.3 - rm -f Tcl_MutexUnlock.3 - rm -f Tcl_MutexFinalize.3 - rm -f Tcl_CreateThread.3 - ln Thread.3 Tcl_ConditionNotify.3 - ln Thread.3 Tcl_ConditionWait.3 - ln Thread.3 Tcl_ConditionFinalize.3 - ln Thread.3 Tcl_GetThreadData.3 - ln Thread.3 Tcl_MutexLock.3 - ln Thread.3 Tcl_MutexUnlock.3 - ln Thread.3 Tcl_MutexFinalize.3 - ln Thread.3 Tcl_CreateThread.3 -fi -if test -r ToUpper.3; then - rm -f Tcl_UniCharToUpper.3 - rm -f Tcl_UniCharToLower.3 - rm -f Tcl_UniCharToTitle.3 - rm -f Tcl_UtfToUpper.3 - rm -f Tcl_UtfToLower.3 - rm -f Tcl_UtfToTitle.3 - ln ToUpper.3 Tcl_UniCharToUpper.3 - ln ToUpper.3 Tcl_UniCharToLower.3 - ln ToUpper.3 Tcl_UniCharToTitle.3 - ln ToUpper.3 Tcl_UtfToUpper.3 - ln ToUpper.3 Tcl_UtfToLower.3 - ln ToUpper.3 Tcl_UtfToTitle.3 -fi -if test -r TraceVar.3; then - rm -f Tcl_TraceVar.3 - rm -f Tcl_TraceVar2.3 - rm -f Tcl_UntraceVar.3 - rm -f Tcl_UntraceVar2.3 - rm -f Tcl_VarTraceInfo.3 - rm -f Tcl_VarTraceInfo2.3 - ln TraceVar.3 Tcl_TraceVar.3 - ln TraceVar.3 Tcl_TraceVar2.3 - ln TraceVar.3 Tcl_UntraceVar.3 - ln TraceVar.3 Tcl_UntraceVar2.3 - ln TraceVar.3 Tcl_VarTraceInfo.3 - ln TraceVar.3 Tcl_VarTraceInfo2.3 -fi -if test -r Translate.3; then - rm -f Tcl_TranslateFileName.3 - ln Translate.3 Tcl_TranslateFileName.3 -fi -if test -r UpVar.3; then - rm -f Tcl_UpVar.3 - rm -f Tcl_UpVar2.3 - ln UpVar.3 Tcl_UpVar.3 - ln UpVar.3 Tcl_UpVar2.3 -fi -if test -r Utf.3; then - rm -f Tcl_UniChar.3 - rm -f Tcl_UniCharToUtf.3 - rm -f Tcl_UtfToUniChar.3 - rm -f Tcl_UniCharToUtfDString.3 - rm -f Tcl_UtfToUniCharDString.3 - rm -f Tcl_UniCharLen.3 - rm -f Tcl_UniCharNcmp.3 - rm -f Tcl_UtfCharComplete.3 - rm -f Tcl_NumUtfChars.3 - rm -f Tcl_UtfFindFirst.3 - rm -f Tcl_UtfFindLast.3 - rm -f Tcl_UtfNext.3 - rm -f Tcl_UtfPrev.3 - rm -f Tcl_UniCharAtIndex.3 - rm -f Tcl_UtfAtIndex.3 - rm -f Tcl_UtfBackslash.3 - ln Utf.3 Tcl_UniChar.3 - ln Utf.3 Tcl_UniCharToUtf.3 - ln Utf.3 Tcl_UtfToUniChar.3 - ln Utf.3 Tcl_UniCharToUtfDString.3 - ln Utf.3 Tcl_UtfToUniCharDString.3 - ln Utf.3 Tcl_UniCharLen.3 - ln Utf.3 Tcl_UniCharNcmp.3 - ln Utf.3 Tcl_UtfCharComplete.3 - ln Utf.3 Tcl_NumUtfChars.3 - ln Utf.3 Tcl_UtfFindFirst.3 - ln Utf.3 Tcl_UtfFindLast.3 - ln Utf.3 Tcl_UtfNext.3 - ln Utf.3 Tcl_UtfPrev.3 - ln Utf.3 Tcl_UniCharAtIndex.3 - ln Utf.3 Tcl_UtfAtIndex.3 - ln Utf.3 Tcl_UtfBackslash.3 -fi -if test -r WrongNumArgs.3; then - rm -f Tcl_WrongNumArgs.3 - ln WrongNumArgs.3 Tcl_WrongNumArgs.3 -fi -if test -r http.n; then - rm -f Http.n - ln http.n Http.n -fi -if test -r library.n; then - rm -f auto_execok.n - rm -f auto_import.n - rm -f auto_load.n - rm -f auto_mkindex.n - rm -f auto_mkindex_old.n - rm -f auto_qualify.n - rm -f auto_reset.n - rm -f tcl_findLibrary.n - rm -f parray.n - rm -f tcl_endOfWord.n - rm -f tcl_startOfNextWord.n - rm -f tcl_startOfPreviousWord.n - rm -f tcl_wordBreakAfter.n - rm -f tcl_wordBreakBefore.n - ln library.n auto_execok.n - ln library.n auto_import.n - ln library.n auto_load.n - ln library.n auto_mkindex.n - ln library.n auto_mkindex_old.n - ln library.n auto_qualify.n - ln library.n auto_reset.n - ln library.n tcl_findLibrary.n - ln library.n parray.n - ln library.n tcl_endOfWord.n - ln library.n tcl_startOfNextWord.n - ln library.n tcl_startOfPreviousWord.n - ln library.n tcl_wordBreakAfter.n - ln library.n tcl_wordBreakBefore.n -fi -if test -r packagens.n; then - rm -f pkg::create.n - ln packagens.n pkg::create.n -fi -if test -r pkgMkIndex.n; then - rm -f pkg_mkIndex.n - ln pkgMkIndex.n pkg_mkIndex.n -fi -if test -r safe.n; then - rm -f SafeBase.n - ln safe.n SafeBase.n -fi -if test -r tcltest.n; then - rm -f Tcltest.n - ln tcltest.n Tcltest.n -fi -exit 0 diff --git a/unix/mkLinks.tcl b/unix/mkLinks.tcl deleted file mode 100644 index 45a6131..0000000 --- a/unix/mkLinks.tcl +++ /dev/null @@ -1,79 +0,0 @@ -#!/bin/sh -# mkLinks.tcl -- -# This generates the mkLinks script -# \ -exec tclsh "$0" ${1+"$@"} - -puts stdout \ -{#!/bin/sh -# This script is invoked when installing manual entries. It generates -# additional links to manual entries, corresponding to the procedure -# and command names described by the manual entry. For example, the -# Tcl manual entry Hash.3 describes procedures Tcl_InitHashTable, -# Tcl_CreateHashEntry, and many more. This script will make hard -# links so that Tcl_InitHashTable.3, Tcl_CreateHashEntry.3, and so -# on all refer to Hash.3 in the installed directory. -# -# Because of the length of command and procedure names, this mechanism -# only works on machines that support file names longer than 14 characters. -# This script checks to see if long file names are supported, and it -# doesn't make any links if they are not. -# -# The script takes one argument, which is the name of the directory -# where the manual entries have been installed. - -if test $# != 1; then - echo "Usage: mkLinks dir" - exit 1 -fi - -cd $1 -echo foo > xyzzyTestingAVeryLongFileName.foo -x=`echo xyzzyTe*` -rm xyzzyTe* -if test "$x" != "xyzzyTestingAVeryLongFileName.foo"; then - exit -fi -} - -foreach file $argv { - set in [open $file] - set tail [file tail $file] - set ext [file extension $file] - set state begin - while {[gets $in line] >= 0} { - switch $state { - begin { - if {[regexp "^.SH NAME" $line]} { - set state name - } - } - name { - regsub {\\-.*} $line {} line - set rmOutput "" - set lnOutput "" - set namelist {} - foreach name [split $line ,] { - regsub -all {(\\)? } $name "" name - if {![string match $name*$ext $tail]} { - lappend namelist $name$ext - append rmOutput " rm -f $name$ext\n" - append lnOutput " ln $tail $name$ext\n" - } - } - if { [llength $namelist] } { - puts "if test -r $tail; then" - puts -nonewline $rmOutput - puts -nonewline $lnOutput - puts "fi" - } - set state end - } - end { - break - } - } - } - close $in -} -puts "exit 0" diff --git a/unix/tcl.m4 b/unix/tcl.m4 deleted file mode 100644 index 8bfded3..0000000 --- a/unix/tcl.m4 +++ /dev/null @@ -1,1750 +0,0 @@ -#------------------------------------------------------------------------ -# SC_PATH_TCLCONFIG -- -# -# Locate the tclConfig.sh file and perform a sanity check on -# the Tcl compile flags -# -# Arguments: -# none -# -# Results: -# -# Adds the following arguments to configure: -# --with-tcl=... -# -# Defines the following vars: -# TCL_BIN_DIR Full path to the directory containing -# the tclConfig.sh file -#------------------------------------------------------------------------ - -AC_DEFUN(SC_PATH_TCLCONFIG, [ - # - # Ok, lets find the tcl configuration - # First, look for one uninstalled. - # the alternative search directory is invoked by --with-tcl - # - - if test x"${no_tcl}" = x ; then - # we reset no_tcl in case something fails here - no_tcl=true - AC_ARG_WITH(tcl, [ --with-tcl directory containing tcl configuration (tclConfig.sh)], with_tclconfig=${withval}) - AC_MSG_CHECKING([for Tcl configuration]) - AC_CACHE_VAL(ac_cv_c_tclconfig,[ - - # First check to see if --with-tclconfig was specified. - if test x"${with_tclconfig}" != x ; then - if test -f "${with_tclconfig}/tclConfig.sh" ; then - ac_cv_c_tclconfig=`(cd ${with_tclconfig}; pwd)` - else - AC_MSG_ERROR([${with_tclconfig} directory doesn't contain tclConfig.sh]) - fi - fi - - # then check for a private Tcl installation - if test x"${ac_cv_c_tclconfig}" = x ; then - for i in \ - ../tcl \ - `ls -dr ../tcl[[8-9]].[[0-9]]* 2>/dev/null` \ - ../../tcl \ - `ls -dr ../../tcl[[8-9]].[[0-9]]* 2>/dev/null` \ - ../../../tcl \ - `ls -dr ../../../tcl[[8-9]].[[0-9]]* 2>/dev/null` ; do - if test -f "$i/unix/tclConfig.sh" ; then - ac_cv_c_tclconfig=`(cd $i/unix; pwd)` - break - fi - done - fi - - # check in a few common install locations - if test x"${ac_cv_c_tclconfig}" = x ; then - for i in `ls -d ${prefix}/lib 2>/dev/null` \ - `ls -d /usr/local/lib 2>/dev/null` ; do - if test -f "$i/tclConfig.sh" ; then - ac_cv_c_tclconfig=`(cd $i; pwd)` - break - fi - done - fi - - # check in a few other private locations - if test x"${ac_cv_c_tcliconfig}" = x ; then - for i in \ - ${srcdir}/../tcl \ - `ls -dr ${srcdir}/../tcl[[8-9]].[[0-9]]* 2>/dev/null` ; do - if test -f "$i/unix/tclConfig.sh" ; then - ac_cv_c_tclconfig=`(cd $i/unix; pwd)` - break - fi - done - fi - ]) - - if test x"${ac_cv_c_tclconfig}" = x ; then - TCL_BIN_DIR="# no Tcl configs found" - AC_MSG_WARN(Can't find Tcl configuration definitions) - exit 0 - else - no_tcl= - TCL_BIN_DIR=${ac_cv_c_tclconfig} - AC_MSG_RESULT(found $TCL_BIN_DIR/tclConfig.sh) - fi - fi -]) - -#------------------------------------------------------------------------ -# SC_PATH_TKCONFIG -- -# -# Locate the tkConfig.sh file -# -# Arguments: -# none -# -# Results: -# -# Adds the following arguments to configure: -# --with-tk=... -# -# Defines the following vars: -# TK_BIN_DIR Full path to the directory containing -# the tkConfig.sh file -#------------------------------------------------------------------------ - -AC_DEFUN(SC_PATH_TKCONFIG, [ - # - # Ok, lets find the tk configuration - # First, look for one uninstalled. - # the alternative search directory is invoked by --with-tk - # - - if test x"${no_tk}" = x ; then - # we reset no_tk in case something fails here - no_tk=true - AC_ARG_WITH(tk, [ --with-tk directory containing tk configuration (tkConfig.sh)], with_tkconfig=${withval}) - AC_MSG_CHECKING([for Tk configuration]) - AC_CACHE_VAL(ac_cv_c_tkconfig,[ - - # First check to see if --with-tkconfig was specified. - if test x"${with_tkconfig}" != x ; then - if test -f "${with_tkconfig}/tkConfig.sh" ; then - ac_cv_c_tkconfig=`(cd ${with_tkconfig}; pwd)` - else - AC_MSG_ERROR([${with_tkconfig} directory doesn't contain tkConfig.sh]) - fi - fi - - # then check for a private Tk library - if test x"${ac_cv_c_tkconfig}" = x ; then - for i in \ - ../tk \ - `ls -dr ../tk[[8-9]].[[0-9]]* 2>/dev/null` \ - ../../tk \ - `ls -dr ../../tk[[8-9]].[[0-9]]* 2>/dev/null` \ - ../../../tk \ - `ls -dr ../../../tk[[8-9]].[[0-9]]* 2>/dev/null` ; do - if test -f "$i/unix/tkConfig.sh" ; then - ac_cv_c_tkconfig=`(cd $i/unix; pwd)` - break - fi - done - fi - # check in a few common install locations - if test x"${ac_cv_c_tkconfig}" = x ; then - for i in `ls -d ${prefix}/lib 2>/dev/null` \ - `ls -d /usr/local/lib 2>/dev/null` ; do - if test -f "$i/tkConfig.sh" ; then - ac_cv_c_tkconfig=`(cd $i; pwd)` - break - fi - done - fi - # check in a few other private locations - if test x"${ac_cv_c_tkconfig}" = x ; then - for i in \ - ${srcdir}/../tk \ - `ls -dr ${srcdir}/../tk[[8-9]].[[0-9]]* 2>/dev/null` ; do - if test -f "$i/unix/tkConfig.sh" ; then - ac_cv_c_tkconfig=`(cd $i/unix; pwd)` - break - fi - done - fi - ]) - if test x"${ac_cv_c_tkconfig}" = x ; then - TK_BIN_DIR="# no Tk configs found" - AC_MSG_WARN(Can't find Tk configuration definitions) - exit 0 - else - no_tk= - TK_BIN_DIR=${ac_cv_c_tkconfig} - AC_MSG_RESULT(found $TK_BIN_DIR/tkConfig.sh) - fi - fi - -]) - -#------------------------------------------------------------------------ -# SC_LOAD_TCLCONFIG -- -# -# Load the tclConfig.sh file -# -# Arguments: -# -# Requires the following vars to be set: -# TCL_BIN_DIR -# -# Results: -# -# Subst the following vars: -# TCL_BIN_DIR -# TCL_SRC_DIR -# TCL_LIB_FILE -# -#------------------------------------------------------------------------ - -AC_DEFUN(SC_LOAD_TCLCONFIG, [ - AC_MSG_CHECKING([for existence of $TCL_BIN_DIR/tclConfig.sh]) - - if test -f "$TCL_BIN_DIR/tclConfig.sh" ; then - AC_MSG_RESULT([loading]) - . $TCL_BIN_DIR/tclConfig.sh - else - AC_MSG_RESULT([file not found]) - fi - - # - # The eval is required to do the TCL_DBGX substitution in the - # TCL_LIB_FILE variable - # - - eval TCL_LIB_FILE=${TCL_LIB_FILE} - eval TCL_LIB_FLAG=${TCL_LIB_FLAG} - - AC_SUBST(TCL_BIN_DIR) - AC_SUBST(TCL_SRC_DIR) - AC_SUBST(TCL_LIB_FILE) -]) - -#------------------------------------------------------------------------ -# SC_LOAD_TKCONFIG -- -# -# Load the tkConfig.sh file -# -# Arguments: -# -# Requires the following vars to be set: -# TK_BIN_DIR -# -# Results: -# -# Sets the following vars that should be in tkConfig.sh: -# TK_BIN_DIR -#------------------------------------------------------------------------ - -AC_DEFUN(SC_LOAD_TKCONFIG, [ - AC_MSG_CHECKING([for existence of $TCLCONFIG]) - - if test -f "$TK_BIN_DIR/tkConfig.sh" ; then - AC_MSG_CHECKING([loading $TK_BIN_DIR/tkConfig.sh]) - . $TK_BIN_DIR/tkConfig.sh - else - AC_MSG_RESULT([could not find $TK_BIN_DIR/tkConfig.sh]) - fi - - AC_SUBST(TK_BIN_DIR) - AC_SUBST(TK_SRC_DIR) - AC_SUBST(TK_LIB_FILE) -]) - -#------------------------------------------------------------------------ -# SC_ENABLE_GCC -- -# -# Allows the use of GCC if available -# -# Arguments: -# none -# -# Results: -# -# Adds the following arguments to configure: -# --enable-gcc -# -# Sets the following vars: -# CC Command to use for the compiler -#------------------------------------------------------------------------ - -AC_DEFUN(SC_ENABLE_GCC, [ - AC_ARG_ENABLE(gcc, [ --enable-gcc allow use of gcc if available [--disable-gcc]], - [ok=$enableval], [ok=no]) - if test "$ok" = "yes"; then - CC=gcc - AC_PROG_CC - else - CC=${CC-cc} - fi -]) - -#------------------------------------------------------------------------ -# SC_ENABLE_SHARED -- -# -# Allows the building of shared libraries -# -# Arguments: -# none -# -# Results: -# -# Adds the following arguments to configure: -# --enable-shared=yes|no -# -# Defines the following vars: -# STATIC_BUILD Used for building import/export libraries -# on Windows. -# -# Sets the following vars: -# SHARED_BUILD Value of 1 or 0 -#------------------------------------------------------------------------ - -AC_DEFUN(SC_ENABLE_SHARED, [ - AC_MSG_CHECKING([how to build libraries]) - AC_ARG_ENABLE(shared, - [ --enable-shared build and link with shared libraries [--enable-shared]], - [tcl_ok=$enableval], [tcl_ok=yes]) - - if test "${enable_shared+set}" = set; then - enableval="$enable_shared" - tcl_ok=$enableval - else - tcl_ok=yes - fi - - if test "$tcl_ok" = "yes" ; then - AC_MSG_RESULT([shared]) - SHARED_BUILD=1 - else - AC_MSG_RESULT([static]) - SHARED_BUILD=0 - AC_DEFINE(STATIC_BUILD) - fi -]) - -#------------------------------------------------------------------------ -# SC_ENABLE_THREADS -- -# -# Specify if thread support should be enabled -# -# Arguments: -# none -# -# Results: -# -# Adds the following arguments to configure: -# --enable-threads -# -# Sets the following vars: -# THREADS_LIBS Thread library(s) -# -# Defines the following vars: -# TCL_THREADS -# _REENTRANT -# -#------------------------------------------------------------------------ - -AC_DEFUN(SC_ENABLE_THREADS, [ - AC_MSG_CHECKING(for building with threads) - AC_ARG_ENABLE(threads, [ --enable-threads build with threads], - [tcl_ok=$enableval], [tcl_ok=no]) - - if test "$tcl_ok" = "yes"; then - AC_MSG_RESULT(yes) - TCL_THREADS=1 - AC_DEFINE(TCL_THREADS) - AC_DEFINE(_REENTRANT) - AC_DEFINE(_THREAD_SAFE) - AC_CHECK_LIB(pthread,pthread_mutex_init,tcl_ok=yes,tcl_ok=no) - if test "$tcl_ok" = "no"; then - # Check a little harder for __pthread_mutex_init in the same - # library, as some systems hide it there until pthread.h is - # defined. We could alternatively do an AC_TRY_COMPILE with - # pthread.h, but that will work with libpthread really doesn't - # exist, like AIX 4.2. [Bug: 4359] - AC_CHECK_LIB(pthread,__pthread_mutex_init,tcl_ok=yes,tcl_ok=no) - fi - - if test "$tcl_ok" = "yes"; then - # The space is needed - THREADS_LIBS=" -lpthread" - else - AC_CHECK_LIB(pthreads,pthread_mutex_init,tcl_ok=yes,tcl_ok=no) - if test "$tcl_ok" = "yes"; then - # The space is needed - THREADS_LIBS=" -lpthreads" - else - AC_CHECK_LIB(c,pthread_mutex_init,tcl_ok=yes,tcl_ok=no) - if test "$tcl_ok" = "no"; then - TCL_THREADS=0 - AC_MSG_WARN("Don t know how to find pthread lib on your system - you must disable thread support or edit the LIBS in the Makefile...") - fi - fi - fi - - # Does the pthread-implementation provide - # 'pthread_attr_setstacksize' ? - - AC_CHECK_FUNCS(pthread_attr_setstacksize) - else - TCL_THREADS=0 - AC_MSG_RESULT(no (default)) - fi -]) - -#------------------------------------------------------------------------ -# SC_ENABLE_SYMBOLS -- -# -# Specify if debugging symbols should be used -# -# Arguments: -# none -# -# Requires the following vars to be set: -# CFLAGS_DEBUG -# CFLAGS_OPTIMIZE -# LDFLAGS_DEBUG -# LDFLAGS_OPTIMIZE -# -# Results: -# -# Adds the following arguments to configure: -# --enable-symbols -# -# Defines the following vars: -# CFLAGS_DEFAULT Sets to CFLAGS_DEBUG if true -# Sets to CFLAGS_OPTIMIZE if false -# LDFLAGS_DEFAULT Sets to LDFLAGS_DEBUG if true -# Sets to LDFLAGS_OPTIMIZE if false -# DBGX Debug library extension -# -#------------------------------------------------------------------------ - -AC_DEFUN(SC_ENABLE_SYMBOLS, [ - AC_MSG_CHECKING([for build with symbols]) - AC_ARG_ENABLE(symbols, [ --enable-symbols build with debugging symbols [--disable-symbols]], [tcl_ok=$enableval], [tcl_ok=no]) - if test "$tcl_ok" = "yes"; then - CFLAGS_DEFAULT="${CFLAGS_DEBUG}" - LDFLAGS_DEFAULT="${LDFLAGS_DEBUG}" - DBGX=g - AC_MSG_RESULT([yes]) - else - CFLAGS_DEFAULT="${CFLAGS_OPTIMIZE}" - LDFLAGS_DEFAULT="${LDFLAGS_OPTIMIZE}" - DBGX="" - AC_MSG_RESULT([no]) - fi -]) - -#-------------------------------------------------------------------- -# SC_CONFIG_CFLAGS -# -# Try to determine the proper flags to pass to the compiler -# for building shared libraries and other such nonsense. -# -# Arguments: -# none -# -# Results: -# -# Defines the following vars: -# -# DL_OBJS - Name of the object file that implements dynamic -# loading for Tcl on this system. -# DL_LIBS - Library file(s) to include in tclsh and other base -# applications in order for the "load" command to work. -# LDFLAGS - Flags to pass to the compiler when linking object -# files into an executable application binary such -# as tclsh. -# LD_SEARCH_FLAGS-Flags to pass to ld, such as "-R /usr/local/tcl/lib", -# that tell the run-time dynamic linker where to look -# for shared libraries such as libtcl.so. Depends on -# the variable LIB_RUNTIME_DIR in the Makefile. -# MAKE_LIB - Command to execute to build the Tcl library; -# differs depending on whether or not Tcl is being -# compiled as a shared library. -# SHLIB_CFLAGS - Flags to pass to cc when compiling the components -# of a shared library (may request position-independent -# code, among other things). -# SHLIB_LD - Base command to use for combining object files -# into a shared library. -# SHLIB_LD_LIBS - Dependent libraries for the linker to scan when -# creating shared libraries. This symbol typically -# goes at the end of the "ld" commands that build -# shared libraries. The value of the symbol is -# "${LIBS}" if all of the dependent libraries should -# be specified when creating a shared library. If -# dependent libraries should not be specified (as on -# SunOS 4.x, where they cause the link to fail, or in -# general if Tcl and Tk aren't themselves shared -# libraries), then this symbol has an empty string -# as its value. -# SHLIB_SUFFIX - Suffix to use for the names of dynamically loadable -# extensions. An empty string means we don't know how -# to use shared libraries on this platform. -# TCL_LIB_FILE - Name of the file that contains the Tcl library, such -# as libtcl7.8.so or libtcl7.8.a. -# TCL_LIB_SUFFIX -Specifies everything that comes after the "libtcl" -# in the shared library name, using the $VERSION variable -# to put the version in the right place. This is used -# by platforms that need non-standard library names. -# Examples: ${VERSION}.so.1.1 on NetBSD, since it needs -# to have a version after the .so, and ${VERSION}.a -# on AIX, since the Tcl shared library needs to have -# a .a extension whereas shared objects for loadable -# extensions have a .so extension. Defaults to -# ${VERSION}${SHLIB_SUFFIX}. -# TCL_NEEDS_EXP_FILE - -# 1 means that an export file is needed to link to a -# shared library. -# TCL_EXP_FILE - The name of the installed export / import file which -# should be used to link to the Tcl shared library. -# Empty if Tcl is unshared. -# TCL_BUILD_EXP_FILE - -# The name of the built export / import file which -# should be used to link to the Tcl shared library. -# Empty if Tcl is unshared. -# CFLAGS_DEBUG - -# Flags used when running the compiler in debug mode -# CFLAGS_OPTIMIZE - -# Flags used when running the compiler in optimize mode -# -# EXTRA_CFLAGS -# -# Subst's the following vars: -# DL_LIBS -# CFLAGS_DEBUG -# CFLAGS_OPTIMIZE -#-------------------------------------------------------------------- - -AC_DEFUN(SC_CONFIG_CFLAGS, [ - - # Step 0.a: Enable 64 bit support? - - AC_MSG_CHECKING([if 64bit support is requested]) - AC_ARG_ENABLE(64bit,[ --enable-64bit enable 64bit support (where applicable)],,enableval="no") - - if test "$enableval" = "yes"; then - do64bit=yes - else - do64bit=no - fi - AC_MSG_RESULT($do64bit) - - # Step 0.b: Enable Solaris 64 bit VIS support? - - AC_MSG_CHECKING([if 64bit Sparc VIS support is requested]) - AC_ARG_ENABLE(64bit-vis,[ --enable-64bit-vis enable 64bit Sparc VIS support],,enableval="no") - - if test "$enableval" = "yes"; then - # Force 64bit on with VIS - do64bit=yes - do64bitVIS=yes - else - do64bitVIS=no - fi - AC_MSG_RESULT($do64bitVIS) - - # Step 1: set the variable "system" to hold the name and version number - # for the system. This can usually be done via the "uname" command, but - # there are a few systems, like Next, where this doesn't work. - - AC_MSG_CHECKING([system version (for dynamic loading)]) - if test -f /usr/lib/NextStep/software_version; then - system=NEXTSTEP-`awk '/3/,/3/' /usr/lib/NextStep/software_version` - else - system=`uname -s`-`uname -r` - if test "$?" -ne 0 ; then - AC_MSG_RESULT([unknown (can't find uname command)]) - system=unknown - else - # Special check for weird MP-RAS system (uname returns weird - # results, and the version is kept in special file). - - if test -r /etc/.relid -a "X`uname -n`" = "X`uname -s`" ; then - system=MP-RAS-`awk '{print $3}' /etc/.relid'` - fi - if test "`uname -s`" = "AIX" ; then - system=AIX-`uname -v`.`uname -r` - fi - AC_MSG_RESULT($system) - fi - fi - - AC_MSG_CHECKING([if gcc is being used]) - if test "$CC" = "gcc" -o `$CC -v 2>&1 | grep -c gcc` != "0" ; then - using_gcc="yes" - else - using_gcc="no" - fi - - AC_MSG_RESULT([$using_gcc ($CC)]) - - # Step 2: check for existence of -ldl library. This is needed because - # Linux can use either -ldl or -ldld for dynamic loading. - - AC_CHECK_LIB(dl, dlopen, have_dl=yes, have_dl=no) - - # Step 3: set configuration options based on system name and version. - - do64bit_ok=no - fullSrcDir=`cd $srcdir; pwd` - EXTRA_CFLAGS="" - TCL_EXPORT_FILE_SUFFIX="" - UNSHARED_LIB_SUFFIX="" - TCL_TRIM_DOTS='`echo ${VERSION} | tr -d .`' - ECHO_VERSION='`echo ${VERSION}`' - TCL_LIB_VERSIONS_OK=ok - CFLAGS_DEBUG=-g - CFLAGS_OPTIMIZE=-O - if test "$using_gcc" = "yes" ; then - CFLAGS_WARNING="-Wall -Wconversion -Wno-implicit-int" - else - CFLAGS_WARNING="" - fi - TCL_NEEDS_EXP_FILE=0 - TCL_BUILD_EXP_FILE="" - TCL_EXP_FILE="" - STLIB_LD="ar cr" - case $system in - AIX-4.[[2-9]]) - if test "${TCL_THREADS}" = "1" -a "$using_gcc" = "no" ; then - # AIX requires the _r compiler when gcc isn't being used - if test "${CC}" != "cc_r" ; then - CC=${CC}_r - fi - AC_MSG_RESULT(Using $CC for compiling with threads) - fi - SHLIB_CFLAGS="" - SHLIB_LD="$fullSrcDir/ldAix /bin/ld -bhalt:4 -bM:SRE -bE:lib.exp -H512 -T512 -bnoentry" - SHLIB_LD_LIBS='${LIBS}' - SHLIB_SUFFIX=".so" - DL_OBJS="tclLoadDl.o" - DL_LIBS="-ldl" - LDFLAGS="" - LD_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}' - TCL_NEEDS_EXP_FILE=1 - TCL_EXPORT_FILE_SUFFIX='${VERSION}\$\{DBGX\}.exp' - ;; - AIX-*) - if test "${TCL_THREADS}" = "1" -a "$using_gcc" = "no" ; then - # AIX requires the _r compiler when gcc isn't being used - if test "${CC}" != "cc_r" ; then - CC=${CC}_r - fi - AC_MSG_RESULT(Using $CC for compiling with threads) - fi - SHLIB_CFLAGS="" - SHLIB_LD="$fullSrcDir/ldAix /bin/ld -bhalt:4 -bM:SRE -bE:lib.exp -H512 -T512 -bnoentry" - SHLIB_LD_LIBS='${LIBS}' - SHLIB_SUFFIX=".so" - DL_OBJS="tclLoadDl.o" - LIBOBJS="$LIBOBJS tclLoadAix.o" - DL_LIBS="-lld" - LDFLAGS="" - LD_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}' - TCL_NEEDS_EXP_FILE=1 - TCL_EXPORT_FILE_SUFFIX='${VERSION}\$\{DBGX\}.exp' - ;; - BSD/OS-2.1*|BSD/OS-3*) - SHLIB_CFLAGS="" - SHLIB_LD="shlicc -r" - SHLIB_LD_LIBS='${LIBS}' - SHLIB_SUFFIX=".so" - DL_OBJS="tclLoadDl.o" - DL_LIBS="-ldl" - LDFLAGS="" - LD_SEARCH_FLAGS="" - ;; - BSD/OS-4.*) - SHLIB_CFLAGS="-export-dynamic -fPIC" - SHLIB_LD="cc -shared" - SHLIB_LD_LIBS='${LIBS}' - SHLIB_SUFFIX=".so" - DL_OBJS="tclLoadDl.o" - DL_LIBS="-ldl" - LDFLAGS="-export-dynamic" - LD_SEARCH_FLAGS="" - ;; - dgux*) - SHLIB_CFLAGS="-K PIC" - SHLIB_LD="cc -G" - SHLIB_LD_LIBS="" - SHLIB_SUFFIX=".so" - DL_OBJS="tclLoadDl.o" - DL_LIBS="-ldl" - LDFLAGS="" - LD_SEARCH_FLAGS="" - ;; - HP-UX-*.08.*|HP-UX-*.09.*|HP-UX-*.10.*|HP-UX-*.11.*) - SHLIB_SUFFIX=".sl" - AC_CHECK_LIB(dld, shl_load, tcl_ok=yes, tcl_ok=no) - if test "$tcl_ok" = yes; then - SHLIB_CFLAGS="+z" - SHLIB_LD="ld -b" - SHLIB_LD_LIBS="" - DL_OBJS="tclLoadShl.o" - DL_LIBS="-ldld" - LDFLAGS="-Wl,-E" - LD_SEARCH_FLAGS='-Wl,+s,+b,${LIB_RUNTIME_DIR}:.' - fi - ;; - IRIX-4.*) - SHLIB_CFLAGS="-G 0" - SHLIB_SUFFIX=".a" - SHLIB_LD="echo tclLdAout $CC \{$SHLIB_CFLAGS\} | `pwd`/tclsh -r -G 0" - SHLIB_LD_LIBS='${LIBS}' - DL_OBJS="tclLoadAout.o" - DL_LIBS="" - LDFLAGS="-Wl,-D,08000000" - LD_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}' - SHARED_LIB_SUFFIX='${VERSION}\$\{DBGX\}.a' - ;; - IRIX-5.*|IRIX-6.*|IRIX64-6.5*) - SHLIB_CFLAGS="" - SHLIB_LD="ld -n32 -shared -rdata_shared" - SHLIB_LD_LIBS='${LIBS}' - SHLIB_SUFFIX=".so" - DL_OBJS="tclLoadDl.o" - DL_LIBS="" - LD_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' - if test "$using_gcc" = "yes" ; then - EXTRA_CFLAGS="-mabi=n32" - LDFLAGS="-mabi=n32" - else - case $system in - IRIX-6.3) - # Use to build 6.2 compatible binaries on 6.3. - EXTRA_CFLAGS="-n32 -D_OLD_TERMIOS" - ;; - *) - EXTRA_CFLAGS="-n32" - ;; - esac - LDFLAGS="-n32" - fi - ;; - IRIX64-6.*) - SHLIB_CFLAGS="" - SHLIB_LD="ld -32 -shared -rdata_shared" - SHLIB_LD_LIBS='${LIBS}' - SHLIB_SUFFIX=".so" - DL_OBJS="tclLoadDl.o" - DL_LIBS="" - LDFLAGS="" - LD_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' - ;; - Linux*) - SHLIB_CFLAGS="-fPIC" - SHLIB_LD_LIBS='${LIBS}' - SHLIB_SUFFIX=".so" - - # egcs-2.91.66 on Redhat Linux 6.0 generates lots of warnings - # when you inline the string and math operations. Turn this off to - # get rid of the warnings. - - CFLAGS_OPTIMIZE="${CFLAGS_OPTIMIZE} -D__NO_STRING_INLINES -D__NO_MATH_INLINES" - - if test "$have_dl" = yes; then - SHLIB_LD="${CC} -shared" - DL_OBJS="tclLoadDl.o" - DL_LIBS="-ldl" - LDFLAGS="-rdynamic" - LD_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' - else - AC_CHECK_HEADER(dld.h, [ - SHLIB_LD="ld -shared" - DL_OBJS="tclLoadDld.o" - DL_LIBS="-ldld" - LDFLAGS="" - LD_SEARCH_FLAGS=""]) - fi - if test "`uname -m`" = "alpha" ; then - EXTRA_CFLAGS="-mieee" - fi - ;; - MP-RAS-02*) - SHLIB_CFLAGS="-K PIC" - SHLIB_LD="cc -G" - SHLIB_LD_LIBS="" - SHLIB_SUFFIX=".so" - DL_OBJS="tclLoadDl.o" - DL_LIBS="-ldl" - LDFLAGS="" - LD_SEARCH_FLAGS="" - ;; - MP-RAS-*) - SHLIB_CFLAGS="-K PIC" - SHLIB_LD="cc -G" - SHLIB_LD_LIBS="" - SHLIB_SUFFIX=".so" - DL_OBJS="tclLoadDl.o" - DL_LIBS="-ldl" - LDFLAGS="-Wl,-Bexport" - LD_SEARCH_FLAGS="" - ;; - NetBSD-*|FreeBSD-[[1-2]].*|OpenBSD-*) - # Not available on all versions: check for include file. - AC_CHECK_HEADER(dlfcn.h, [ - # NetBSD/SPARC needs -fPIC, -fpic will not do. - SHLIB_CFLAGS="-fPIC" - SHLIB_LD="ld -Bshareable -x" - SHLIB_LD_LIBS="" - SHLIB_SUFFIX=".so" - DL_OBJS="tclLoadDl.o" - DL_LIBS="" - LDFLAGS="" - LD_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' - AC_MSG_CHECKING(for ELF) - AC_EGREP_CPP(yes, [ -#ifdef __ELF__ - yes -#endif - ], - AC_MSG_RESULT(yes) - SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.so', - AC_MSG_RESULT(no) - SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.so.1.0' - ) - ], [ - SHLIB_CFLAGS="" - SHLIB_LD="echo tclLdAout $CC \{$SHLIB_CFLAGS\} | `pwd`/tclsh -r" - SHLIB_LD_LIBS='${LIBS}' - SHLIB_SUFFIX=".a" - DL_OBJS="tclLoadAout.o" - DL_LIBS="" - LDFLAGS="" - LD_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}' - SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.a' - ]) - - # FreeBSD doesn't handle version numbers with dots. - - UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.a' - TCL_LIB_VERSIONS_OK=nodots - ;; - FreeBSD-*) - # FreeBSD 3.* and greater have ELF. - SHLIB_CFLAGS="-fPIC" - SHLIB_LD="ld -Bshareable -x" - SHLIB_LD_LIBS="" - SHLIB_SUFFIX=".so" - DL_OBJS="tclLoadDl.o" - DL_LIBS="" - LDFLAGS="-export-dynamic" - LD_SEARCH_FLAGS="" - ;; - NEXTSTEP-*) - SHLIB_CFLAGS="" - SHLIB_LD="cc -nostdlib -r" - SHLIB_LD_LIBS="" - SHLIB_SUFFIX=".so" - DL_OBJS="tclLoadNext.o" - DL_LIBS="" - LDFLAGS="" - LD_SEARCH_FLAGS="" - ;; - OS/390-*) - CFLAGS_OPTIMIZE="" # Optimizer is buggy - AC_DEFINE(_OE_SOCKETS) # needed in sys/socket.h - ;; - OSF1-1.0|OSF1-1.1|OSF1-1.2) - # OSF/1 1.[012] from OSF, and derivatives, including Paragon OSF/1 - SHLIB_CFLAGS="" - # Hack: make package name same as library name - SHLIB_LD='ld -R -export $@:' - SHLIB_LD_LIBS="" - SHLIB_SUFFIX=".so" - DL_OBJS="tclLoadOSF.o" - DL_LIBS="" - LDFLAGS="" - LD_SEARCH_FLAGS="" - ;; - OSF1-1.*) - # OSF/1 1.3 from OSF using ELF, and derivatives, including AD2 - SHLIB_CFLAGS="-fPIC" - SHLIB_LD="ld -shared" - SHLIB_LD_LIBS="" - SHLIB_SUFFIX=".so" - DL_OBJS="tclLoadDl.o" - DL_LIBS="" - LDFLAGS="" - LD_SEARCH_FLAGS="" - ;; - OSF1-V*) - # Digital OSF/1 - SHLIB_CFLAGS="" - SHLIB_LD='ld -shared -expect_unresolved "*"' - SHLIB_LD_LIBS="" - SHLIB_SUFFIX=".so" - DL_OBJS="tclLoadDl.o" - DL_LIBS="" - LDFLAGS="" - LD_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' - if test "$using_gcc" = "no" ; then - EXTRA_CFLAGS="-DHAVE_TZSET -std1" - fi - # see pthread_intro(3) for pthread support on osf1, k.furukawa - if test "${TCL_THREADS}" = "1" ; then - EXTRA_CFLAGS="${EXTRA_CFLAGS} -DTCL_THREAD_STACK_MIN=PTHREAD_STACK_MIN*64" - if test "$using_gcc" = "no" ; then - EXTRA_CFLAGS="${EXTRA_CFLAGS} -pthread" - LDFLAGS="-pthread" - else - LIBS=`echo $LIBS | sed s/-lpthreads//` - LIBS="$LIBS -lpthread -lmach -lexc" - fi - fi - - ;; - RISCos-*) - SHLIB_CFLAGS="-G 0" - SHLIB_LD="echo tclLdAout $CC \{$SHLIB_CFLAGS\} | `pwd`/tclsh -r -G 0" - SHLIB_LD_LIBS='${LIBS}' - SHLIB_SUFFIX=".a" - DL_OBJS="tclLoadAout.o" - DL_LIBS="" - LDFLAGS="-Wl,-D,08000000" - LD_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}' - ;; - SCO_SV-3.2*) - # Note, dlopen is available only on SCO 3.2.5 and greater. However, - # this test works, since "uname -s" was non-standard in 3.2.4 and - # below. - if test "$using_gcc" = "yes" ; then - SHLIB_CFLAGS="-fPIC -melf" - LDFLAGS="-melf -Wl,-Bexport" - else - SHLIB_CFLAGS="-Kpic -belf" - LDFLAGS="-belf -Wl,-Bexport" - fi - SHLIB_LD="ld -G" - SHLIB_LD_LIBS="" - SHLIB_SUFFIX=".so" - DL_OBJS="tclLoadDl.o" - DL_LIBS="" - LD_SEARCH_FLAGS="" - ;; - SINIX*5.4*) - SHLIB_CFLAGS="-K PIC" - SHLIB_LD="cc -G" - SHLIB_LD_LIBS="" - SHLIB_SUFFIX=".so" - DL_OBJS="tclLoadDl.o" - DL_LIBS="-ldl" - LDFLAGS="" - LD_SEARCH_FLAGS="" - ;; - SunOS-4*) - SHLIB_CFLAGS="-PIC" - SHLIB_LD="ld" - SHLIB_LD_LIBS="" - SHLIB_SUFFIX=".so" - DL_OBJS="tclLoadDl.o" - DL_LIBS="-ldl" - LDFLAGS="" - LD_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}' - - # SunOS can't handle version numbers with dots in them in library - # specs, like -ltcl7.5, so use -ltcl75 instead. Also, it - # requires an extra version number at the end of .so file names. - # So, the library has to have a name like libtcl75.so.1.0 - - SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.so.1.0' - UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.a' - TCL_LIB_VERSIONS_OK=nodots - ;; - SunOS-5.[[0-6]]*) - SHLIB_CFLAGS="-KPIC" - SHLIB_LD="/usr/ccs/bin/ld -G -z text" - - # Note: need the LIBS below, otherwise Tk won't find Tcl's - # symbols when dynamically loaded into tclsh. - - SHLIB_LD_LIBS='${LIBS}' - SHLIB_SUFFIX=".so" - DL_OBJS="tclLoadDl.o" - DL_LIBS="-ldl" - LDFLAGS="" - LD_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}' - ;; - SunOS-5*) - SHLIB_CFLAGS="-KPIC" - SHLIB_LD="/usr/ccs/bin/ld -G -z text" - LDFLAGS="" - - do64bit_ok=no - if test "$do64bit" = "yes" ; then - arch=`isainfo` - if test "$arch" = "sparcv9 sparc" ; then - if test "$using_gcc" = "no" ; then - do64bit_ok=yes - if test "$do64bitVIS" = "yes" ; then - EXTRA_CFLAGS="-xarch=v9a" - LDFLAGS="-xarch=v9a" - else - EXTRA_CFLAGS="-xarch=v9" - LDFLAGS="-xarch=v9" - fi - else - AC_MSG_WARN("64bit mode not supported with GCC on $system") - fi - else - AC_MSG_WARN("64bit mode only supported sparcv9 system") - fi - fi - - # Note: need the LIBS below, otherwise Tk won't find Tcl's - # symbols when dynamically loaded into tclsh. - - SHLIB_LD_LIBS='${LIBS}' - SHLIB_SUFFIX=".so" - DL_OBJS="tclLoadDl.o" - DL_LIBS="-ldl" - if test "$using_gcc" = "yes" ; then - LD_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}' - else - LD_SEARCH_FLAGS='-R ${LIB_RUNTIME_DIR}' - fi - ;; - ULTRIX-4.*) - SHLIB_CFLAGS="-G 0" - SHLIB_SUFFIX=".a" - SHLIB_LD="echo tclLdAout $CC \{$SHLIB_CFLAGS\} | `pwd`/tclsh -r -G 0" - SHLIB_LD_LIBS='${LIBS}' - DL_OBJS="tclLoadAout.o" - DL_LIBS="" - LDFLAGS="-Wl,-D,08000000" - LD_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}' - if test "$using_gcc" = "no" ; then - EXTRA_CFLAGS="-DHAVE_TZSET -std1" - fi - ;; - UNIX_SV* | UnixWare-5*) - SHLIB_CFLAGS="-KPIC" - SHLIB_LD="cc -G" - SHLIB_LD_LIBS="" - SHLIB_SUFFIX=".so" - DL_OBJS="tclLoadDl.o" - DL_LIBS="-ldl" - # Some UNIX_SV* systems (unixware 1.1.2 for example) have linkers - # that don't grok the -Bexport option. Test that it does. - hold_ldflags=$LDFLAGS - AC_MSG_CHECKING(for ld accepts -Bexport flag) - LDFLAGS="${LDFLAGS} -Wl,-Bexport" - AC_TRY_LINK(, [int i;], found=yes, found=no) - LDFLAGS=$hold_ldflags - AC_MSG_RESULT($found) - if test $found = yes; then - LDFLAGS="-Wl,-Bexport" - else - LDFLAGS="" - fi - LD_SEARCH_FLAGS="" - ;; - esac - - if test "$do64bit" = "yes" -a "$do64bit_ok" = "no" ; then - AC_MSG_WARN("64bit support being disabled -- don\'t know magic for this platform") - fi - - # Step 4: If pseudo-static linking is in use (see K. B. Kenny, "Dynamic - # Loading for Tcl -- What Became of It?". Proc. 2nd Tcl/Tk Workshop, - # New Orleans, LA, Computerized Processes Unlimited, 1994), then we need - # to determine which of several header files defines the a.out file - # format (a.out.h, sys/exec.h, or sys/exec_aout.h). At present, we - # support only a file format that is more or less version-7-compatible. - # In particular, - # - a.out files must begin with `struct exec'. - # - the N_TXTOFF on the `struct exec' must compute the seek address - # of the text segment - # - The `struct exec' must contain a_magic, a_text, a_data, a_bss - # and a_entry fields. - # The following compilation should succeed if and only if either sys/exec.h - # or a.out.h is usable for the purpose. - # - # Note that the modified COFF format used on MIPS Ultrix 4.x is usable; the - # `struct exec' includes a second header that contains information that - # duplicates the v7 fields that are needed. - - if test "x$DL_OBJS" = "xtclLoadAout.o" ; then - AC_MSG_CHECKING(sys/exec.h) - AC_TRY_COMPILE([#include <sys/exec.h>],[ - struct exec foo; - unsigned long seek; - int flag; -#if defined(__mips) || defined(mips) - seek = N_TXTOFF (foo.ex_f, foo.ex_o); -#else - seek = N_TXTOFF (foo); -#endif - flag = (foo.a_magic == OMAGIC); - return foo.a_text + foo.a_data + foo.a_bss + foo.a_entry; - ], tcl_ok=usable, tcl_ok=unusable) - AC_MSG_RESULT($tcl_ok) - if test $tcl_ok = usable; then - AC_DEFINE(USE_SYS_EXEC_H) - else - AC_MSG_CHECKING(a.out.h) - AC_TRY_COMPILE([#include <a.out.h>],[ - struct exec foo; - unsigned long seek; - int flag; -#if defined(__mips) || defined(mips) - seek = N_TXTOFF (foo.ex_f, foo.ex_o); -#else - seek = N_TXTOFF (foo); -#endif - flag = (foo.a_magic == OMAGIC); - return foo.a_text + foo.a_data + foo.a_bss + foo.a_entry; - ], tcl_ok=usable, tcl_ok=unusable) - AC_MSG_RESULT($tcl_ok) - if test $tcl_ok = usable; then - AC_DEFINE(USE_A_OUT_H) - else - AC_MSG_CHECKING(sys/exec_aout.h) - AC_TRY_COMPILE([#include <sys/exec_aout.h>],[ - struct exec foo; - unsigned long seek; - int flag; -#if defined(__mips) || defined(mips) - seek = N_TXTOFF (foo.ex_f, foo.ex_o); -#else - seek = N_TXTOFF (foo); -#endif - flag = (foo.a_midmag == OMAGIC); - return foo.a_text + foo.a_data + foo.a_bss + foo.a_entry; - ], tcl_ok=usable, tcl_ok=unusable) - AC_MSG_RESULT($tcl_ok) - if test $tcl_ok = usable; then - AC_DEFINE(USE_SYS_EXEC_AOUT_H) - else - DL_OBJS="" - fi - fi - fi - fi - - # Step 5: disable dynamic loading if requested via a command-line switch. - - AC_ARG_ENABLE(load, [ --disable-load disallow dynamic loading and "load" command], - [tcl_ok=$enableval], [tcl_ok=yes]) - if test "$tcl_ok" = "no"; then - DL_OBJS="" - fi - - if test "x$DL_OBJS" != "x" ; then - BUILD_DLTEST="\$(DLTEST_TARGETS)" - else - echo "Can't figure out how to do dynamic loading or shared libraries" - echo "on this system." - SHLIB_CFLAGS="" - SHLIB_LD="" - SHLIB_SUFFIX="" - DL_OBJS="tclLoadNone.o" - DL_LIBS="" - LDFLAGS="" - LD_SEARCH_FLAGS="" - BUILD_DLTEST="" - fi - - # If we're running gcc, then change the C flags for compiling shared - # libraries to the right flags for gcc, instead of those for the - # standard manufacturer compiler. - - if test "$DL_OBJS" != "tclLoadNone.o" ; then - if test "$using_gcc" = "yes" ; then - case $system in - AIX-*) - ;; - BSD/OS*) - ;; - IRIX*) - ;; - NetBSD-*|FreeBSD-*|OpenBSD-*) - ;; - RISCos-*) - ;; - SCO_SV-3.2*) - ;; - ULTRIX-4.*) - ;; - *) - SHLIB_CFLAGS="-fPIC" - ;; - esac - fi - fi - - if test "$SHARED_LIB_SUFFIX" = "" ; then - SHARED_LIB_SUFFIX='${VERSION}\$\{DBGX\}${SHLIB_SUFFIX}' - fi - if test "$UNSHARED_LIB_SUFFIX" = "" ; then - UNSHARED_LIB_SUFFIX='${VERSION}\$\{DBGX\}.a' - fi - - AC_SUBST(DL_LIBS) - AC_SUBST(CFLAGS_DEBUG) - AC_SUBST(CFLAGS_OPTIMIZE) - AC_SUBST(CFLAGS_WARNING) -]) - -#-------------------------------------------------------------------- -# SC_SERIAL_PORT -# -# Determine which interface to use to talk to the serial port. -# Note that #include lines must begin in leftmost column for -# some compilers to recognize them as preprocessor directives. -# -# Arguments: -# none -# -# Results: -# -# Defines only one of the following vars: -# USE_TERMIOS -# USE_TERMIO -# USE_SGTTY -# -#-------------------------------------------------------------------- - -AC_DEFUN(SC_SERIAL_PORT, [ - AC_MSG_CHECKING([termios vs. termio vs. sgtty]) - - AC_TRY_RUN([ -#include <termios.h> - -main() -{ - struct termios t; - if (tcgetattr(0, &t) == 0) { - cfsetospeed(&t, 0); - t.c_cflag |= PARENB | PARODD | CSIZE | CSTOPB; - return 0; - } - return 1; -}], tk_ok=termios, tk_ok=no, tk_ok=no) - - if test $tk_ok = termios; then - AC_DEFINE(USE_TERMIOS) - else - AC_TRY_RUN([ -#include <termio.h> - -main() -{ - struct termio t; - if (ioctl(0, TCGETA, &t) == 0) { - t.c_cflag |= CBAUD | PARENB | PARODD | CSIZE | CSTOPB; - return 0; - } - return 1; - }], tk_ok=termio, tk_ok=no, tk_ok=no) - - if test $tk_ok = termio; then - AC_DEFINE(USE_TERMIO) - else - AC_TRY_RUN([ -#include <sgtty.h> - -main() -{ - struct sgttyb t; - if (ioctl(0, TIOCGETP, &t) == 0) { - t.sg_ospeed = 0; - t.sg_flags |= ODDP | EVENP | RAW; - return 0; - } - return 1; -}], tk_ok=sgtty, tk_ok=none, tk_ok=none) - if test $tk_ok = sgtty; then - AC_DEFINE(USE_SGTTY) - fi - fi - fi - AC_MSG_RESULT($tk_ok) -]) - -#-------------------------------------------------------------------- -# SC_MISSING_POSIX_HEADERS -# -# Supply substitutes for missing POSIX header files. Special -# notes: -# - stdlib.h doesn't define strtol, strtoul, or -# strtod insome versions of SunOS -# - some versions of string.h don't declare procedures such -# as strstr -# -# Arguments: -# none -# -# Results: -# -# Defines some of the following vars: -# NO_DIRENT_H -# NO_ERRNO_H -# NO_VALUES_H -# NO_LIMITS_H -# NO_STDLIB_H -# NO_STRING_H -# NO_SYS_WAIT_H -# NO_DLFCN_H -# HAVE_UNISTD_H -# HAVE_SYS_PARAM_H -# -# HAVE_STRING_H ? -# -#-------------------------------------------------------------------- - -AC_DEFUN(SC_MISSING_POSIX_HEADERS, [ - - AC_MSG_CHECKING(dirent.h) - AC_TRY_LINK([#include <sys/types.h> -#include <dirent.h>], [ -#ifndef _POSIX_SOURCE -# ifdef __Lynx__ - /* - * Generate compilation error to make the test fail: Lynx headers - * are only valid if really in the POSIX environment. - */ - - missing_procedure(); -# endif -#endif -DIR *d; -struct dirent *entryPtr; -char *p; -d = opendir("foobar"); -entryPtr = readdir(d); -p = entryPtr->d_name; -closedir(d); -], tcl_ok=yes, tcl_ok=no) - - if test $tcl_ok = no; then - AC_DEFINE(NO_DIRENT_H) - fi - - AC_MSG_RESULT($tcl_ok) - AC_CHECK_HEADER(errno.h, , AC_DEFINE(NO_ERRNO_H)) - AC_CHECK_HEADER(float.h, , AC_DEFINE(NO_FLOAT_H)) - AC_CHECK_HEADER(values.h, , AC_DEFINE(NO_VALUES_H)) - AC_CHECK_HEADER(limits.h, , AC_DEFINE(NO_LIMITS_H)) - AC_CHECK_HEADER(stdlib.h, tcl_ok=1, tcl_ok=0) - AC_EGREP_HEADER(strtol, stdlib.h, , tcl_ok=0) - AC_EGREP_HEADER(strtoul, stdlib.h, , tcl_ok=0) - AC_EGREP_HEADER(strtod, stdlib.h, , tcl_ok=0) - if test $tcl_ok = 0; then - AC_DEFINE(NO_STDLIB_H) - fi - AC_CHECK_HEADER(string.h, tcl_ok=1, tcl_ok=0) - AC_EGREP_HEADER(strstr, string.h, , tcl_ok=0) - AC_EGREP_HEADER(strerror, string.h, , tcl_ok=0) - - # See also memmove check below for a place where NO_STRING_H can be - # set and why. - - if test $tcl_ok = 0; then - AC_DEFINE(NO_STRING_H) - fi - - AC_CHECK_HEADER(sys/wait.h, , AC_DEFINE(NO_SYS_WAIT_H)) - AC_CHECK_HEADER(dlfcn.h, , AC_DEFINE(NO_DLFCN_H)) - - # OS/390 lacks sys/param.h (and doesn't need it, by chance). - - AC_HAVE_HEADERS(unistd.h sys/param.h) - -]) - -#-------------------------------------------------------------------- -# SC_PATH_X -# -# Locate the X11 header files and the X11 library archive. Try -# the ac_path_x macro first, but if it doesn't find the X stuff -# (e.g. because there's no xmkmf program) then check through -# a list of possible directories. Under some conditions the -# autoconf macro will return an include directory that contains -# no include files, so double-check its result just to be safe. -# -# Arguments: -# none -# -# Results: -# -# Sets the the following vars: -# XINCLUDES -# XLIBSW -# -#-------------------------------------------------------------------- - -AC_DEFUN(SC_PATH_X, [ - AC_PATH_X - not_really_there="" - if test "$no_x" = ""; then - if test "$x_includes" = ""; then - AC_TRY_CPP([#include <X11/XIntrinsic.h>], , not_really_there="yes") - else - if test ! -r $x_includes/X11/Intrinsic.h; then - not_really_there="yes" - fi - fi - fi - if test "$no_x" = "yes" -o "$not_really_there" = "yes"; then - AC_MSG_CHECKING(for X11 header files) - XINCLUDES="# no special path needed" - AC_TRY_CPP([#include <X11/Intrinsic.h>], , XINCLUDES="nope") - if test "$XINCLUDES" = nope; then - dirs="/usr/unsupported/include /usr/local/include /usr/X386/include /usr/X11R6/include /usr/X11R5/include /usr/include/X11R5 /usr/include/X11R4 /usr/openwin/include /usr/X11/include /usr/sww/include" - for i in $dirs ; do - if test -r $i/X11/Intrinsic.h; then - AC_MSG_RESULT($i) - XINCLUDES=" -I$i" - break - fi - done - fi - else - if test "$x_includes" != ""; then - XINCLUDES=-I$x_includes - else - XINCLUDES="# no special path needed" - fi - fi - if test "$XINCLUDES" = nope; then - AC_MSG_RESULT(couldn't find any!) - XINCLUDES="# no include files found" - fi - - if test "$no_x" = yes; then - AC_MSG_CHECKING(for X11 libraries) - XLIBSW=nope - dirs="/usr/unsupported/lib /usr/local/lib /usr/X386/lib /usr/X11R6/lib /usr/X11R5/lib /usr/lib/X11R5 /usr/lib/X11R4 /usr/openwin/lib /usr/X11/lib /usr/sww/X11/lib" - for i in $dirs ; do - if test -r $i/libX11.a -o -r $i/libX11.so -o -r $i/libX11.sl; then - AC_MSG_RESULT($i) - XLIBSW="-L$i -lX11" - x_libraries="$i" - break - fi - done - else - if test "$x_libraries" = ""; then - XLIBSW=-lX11 - else - XLIBSW="-L$x_libraries -lX11" - fi - fi - if test "$XLIBSW" = nope ; then - AC_CHECK_LIB(Xwindow, XCreateWindow, XLIBSW=-lXwindow) - fi - if test "$XLIBSW" = nope ; then - AC_MSG_RESULT(couldn't find any! Using -lX11.) - XLIBSW=-lX11 - fi -]) -#-------------------------------------------------------------------- -# SC_BLOCKING_STYLE -# -# The statements below check for systems where POSIX-style -# non-blocking I/O (O_NONBLOCK) doesn't work or is unimplemented. -# On these systems (mostly older ones), use the old BSD-style -# FIONBIO approach instead. -# -# Arguments: -# none -# -# Results: -# -# Defines some of the following vars: -# HAVE_SYS_IOCTL_H -# HAVE_SYS_FILIO_H -# USE_FIONBIO -# O_NONBLOCK -# -#-------------------------------------------------------------------- - -AC_DEFUN(SC_BLOCKING_STYLE, [ - AC_CHECK_HEADERS(sys/ioctl.h) - AC_CHECK_HEADERS(sys/filio.h) - AC_MSG_CHECKING([FIONBIO vs. O_NONBLOCK for nonblocking I/O]) - if test -f /usr/lib/NextStep/software_version; then - system=NEXTSTEP-`awk '/3/,/3/' /usr/lib/NextStep/software_version` - else - system=`uname -s`-`uname -r` - if test "$?" -ne 0 ; then - system=unknown - else - # Special check for weird MP-RAS system (uname returns weird - # results, and the version is kept in special file). - - if test -r /etc/.relid -a "X`uname -n`" = "X`uname -s`" ; then - system=MP-RAS-`awk '{print $3}' /etc/.relid'` - fi - if test "`uname -s`" = "AIX" ; then - system=AIX-`uname -v`.`uname -r` - fi - fi - fi - case $system in - # There used to be code here to use FIONBIO under AIX. However, it - # was reported that FIONBIO doesn't work under AIX 3.2.5. Since - # using O_NONBLOCK seems fine under AIX 4.*, I removed the FIONBIO - # code (JO, 5/31/97). - - OSF*) - AC_DEFINE(USE_FIONBIO) - AC_MSG_RESULT(FIONBIO) - ;; - SunOS-4*) - AC_DEFINE(USE_FIONBIO) - AC_MSG_RESULT(FIONBIO) - ;; - ULTRIX-4.*) - AC_DEFINE(USE_FIONBIO) - AC_MSG_RESULT(FIONBIO) - ;; - *) - AC_MSG_RESULT(O_NONBLOCK) - ;; - esac -]) - -#-------------------------------------------------------------------- -# SC_TIME_HANLDER -# -# Checks how the system deals with time.h, what time structures -# are used on the system, and what fields the structures have. -# -# Arguments: -# none -# -# Results: -# -# Defines some of the following vars: -# USE_DELTA_FOR_TZ -# HAVE_TM_GMTOFF -# HAVE_TM_TZADJ -# HAVE_TIMEZONE_VAR -# -#-------------------------------------------------------------------- - -AC_DEFUN(SC_TIME_HANDLER, [ - AC_CHECK_HEADERS(sys/time.h) - AC_HEADER_TIME - AC_STRUCT_TIMEZONE - - AC_MSG_CHECKING([tm_tzadj in struct tm]) - AC_TRY_COMPILE([#include <time.h>], [struct tm tm; tm.tm_tzadj;], - [AC_DEFINE(HAVE_TM_TZADJ) - AC_MSG_RESULT(yes)], - AC_MSG_RESULT(no)) - - AC_MSG_CHECKING([tm_gmtoff in struct tm]) - AC_TRY_COMPILE([#include <time.h>], [struct tm tm; tm.tm_gmtoff;], - [AC_DEFINE(HAVE_TM_GMTOFF) - AC_MSG_RESULT(yes)], - AC_MSG_RESULT(no)) - - # - # Its important to include time.h in this check, as some systems - # (like convex) have timezone functions, etc. - # - have_timezone=no - AC_MSG_CHECKING([long timezone variable]) - AC_TRY_COMPILE([#include <time.h>], - [extern long timezone; - timezone += 1; - exit (0);], - [have_timezone=yes - AC_DEFINE(HAVE_TIMEZONE_VAR) - AC_MSG_RESULT(yes)], - AC_MSG_RESULT(no)) - - # - # On some systems (eg IRIX 6.2), timezone is a time_t and not a long. - # - if test "$have_timezone" = no; then - AC_MSG_CHECKING([time_t timezone variable]) - AC_TRY_COMPILE([#include <time.h>], - [extern time_t timezone; - timezone += 1; - exit (0);], - [AC_DEFINE(HAVE_TIMEZONE_VAR) - AC_MSG_RESULT(yes)], - AC_MSG_RESULT(no)) - fi - - # - # AIX does not have a timezone field in struct tm. When the AIX bsd - # library is used, the timezone global and the gettimeofday methods are - # to be avoided for timezone deduction instead, we deduce the timezone - # by comparing the localtime result on a known GMT value. - # - - if test "`uname -s`" = "AIX" ; then - AC_CHECK_LIB(bsd, gettimeofday, libbsd=yes) - if test $libbsd = yes; then - AC_DEFINE(USE_DELTA_FOR_TZ) - fi - fi -]) - -#-------------------------------------------------------------------- -# SC_BUGGY_STRTOD -# -# Under Solaris 2.4, strtod returns the wrong value for the -# terminating character under some conditions. Check for this -# and if the problem exists use a substitute procedure -# "fixstrtod" (provided by Tcl) that corrects the error. -# Also, on Compaq's Tru64 Unix 5.0, -# strtod(" ") returns 0.0 instead of a failure to convert. -# -# Arguments: -# none -# -# Results: -# -# Might defines some of the following vars: -# strtod (=fixstrtod) -# -#-------------------------------------------------------------------- - -AC_DEFUN(SC_BUGGY_STRTOD, [ - AC_CHECK_FUNC(strtod, tcl_strtod=1, tcl_strtod=0) - if test "$tcl_strtod" = 1; then - AC_MSG_CHECKING([for Solaris2.4/Tru64 strtod bugs]) - AC_TRY_RUN([ - extern double strtod(); - int main() - { - char *string = "NaN", *spaceString = " "; - char *term; - double value; - value = strtod(string, &term); - if ((term != string) && (term[-1] == 0)) { - exit(1); - } - value = strtod(spaceString, &term); - if (term == (spaceString+1)) { - exit(1); - } - exit(0); - }], tcl_ok=1, tcl_ok=0, tcl_ok=0) - if test "$tcl_ok" = 1; then - AC_MSG_RESULT(ok) - else - AC_MSG_RESULT(buggy) - LIBOBJS="$LIBOBJS fixstrtod.o" - AC_DEFINE(strtod, fixstrtod) - fi - fi -]) - -#-------------------------------------------------------------------- -# SC_TCL_LINK_LIBS -# -# Search for the libraries needed to link the Tcl shell. -# Things like the math library (-lm) and socket stuff (-lsocket vs. -# -lnsl) are dealt with here. -# -# Arguments: -# Requires the following vars to be set in the Makefile: -# DL_LIBS -# LIBS -# MATH_LIBS -# -# Results: -# -# Subst's the following var: -# TCL_LIBS -# MATH_LIBS -# -# Might append to the following vars: -# LIBS -# -# Might define the following vars: -# HAVE_NET_ERRNO_H -# -#-------------------------------------------------------------------- - -AC_DEFUN(SC_TCL_LINK_LIBS, [ - #-------------------------------------------------------------------- - # On a few very rare systems, all of the libm.a stuff is - # already in libc.a. Set compiler flags accordingly. - # Also, Linux requires the "ieee" library for math to work - # right (and it must appear before "-lm"). - #-------------------------------------------------------------------- - - AC_CHECK_FUNC(sin, MATH_LIBS="", MATH_LIBS="-lm") - AC_CHECK_LIB(ieee, main, [MATH_LIBS="-lieee $MATH_LIBS"]) - - #-------------------------------------------------------------------- - # On AIX systems, libbsd.a has to be linked in to support - # non-blocking file IO. This library has to be linked in after - # the MATH_LIBS or it breaks the pow() function. The way to - # insure proper sequencing, is to add it to the tail of MATH_LIBS. - # This library also supplies gettimeofday. - #-------------------------------------------------------------------- - - libbsd=no - if test "`uname -s`" = "AIX" ; then - AC_CHECK_LIB(bsd, gettimeofday, libbsd=yes) - if test $libbsd = yes; then - MATH_LIBS="$MATH_LIBS -lbsd" - fi - fi - - - #-------------------------------------------------------------------- - # Interactive UNIX requires -linet instead of -lsocket, plus it - # needs net/errno.h to define the socket-related error codes. - #-------------------------------------------------------------------- - - AC_CHECK_LIB(inet, main, [LIBS="$LIBS -linet"]) - AC_CHECK_HEADER(net/errno.h, AC_DEFINE(HAVE_NET_ERRNO_H)) - - #-------------------------------------------------------------------- - # Check for the existence of the -lsocket and -lnsl libraries. - # The order here is important, so that they end up in the right - # order in the command line generated by make. Here are some - # special considerations: - # 1. Use "connect" and "accept" to check for -lsocket, and - # "gethostbyname" to check for -lnsl. - # 2. Use each function name only once: can't redo a check because - # autoconf caches the results of the last check and won't redo it. - # 3. Use -lnsl and -lsocket only if they supply procedures that - # aren't already present in the normal libraries. This is because - # IRIX 5.2 has libraries, but they aren't needed and they're - # bogus: they goof up name resolution if used. - # 4. On some SVR4 systems, can't use -lsocket without -lnsl too. - # To get around this problem, check for both libraries together - # if -lsocket doesn't work by itself. - #-------------------------------------------------------------------- - - tcl_checkBoth=0 - AC_CHECK_FUNC(connect, tcl_checkSocket=0, tcl_checkSocket=1) - if test "$tcl_checkSocket" = 1; then - AC_CHECK_FUNC(setsockopt, , AC_CHECK_LIB(socket, setsockopt, - LIBS="$LIBS -lsocket", tcl_checkBoth=1)) - fi - if test "$tcl_checkBoth" = 1; then - tk_oldLibs=$LIBS - LIBS="$LIBS -lsocket -lnsl" - AC_CHECK_FUNC(accept, tcl_checkNsl=0, [LIBS=$tk_oldLibs]) - fi - AC_CHECK_FUNC(gethostbyname, , AC_CHECK_LIB(nsl, gethostbyname, - [LIBS="$LIBS -lnsl"])) - - # Don't perform the eval of the libraries here because DL_LIBS - # won't be set until we call SC_CONFIG_CFLAGS - - TCL_LIBS='${DL_LIBS} ${LIBS} ${MATH_LIBS}' - AC_SUBST(TCL_LIBS) - AC_SUBST(MATH_LIBS) -]) diff --git a/unix/tcl.spec b/unix/tcl.spec deleted file mode 100644 index d8f5ae0..0000000 --- a/unix/tcl.spec +++ /dev/null @@ -1,53 +0,0 @@ -# $Id: tcl.spec,v 1.4.2.1 2000/07/27 01:39:23 hobbs Exp $ -# This file is the basis for a binary Tcl RPM for Linux. - -%define version 8.3.2 -%define directory /usr/local - -Summary: Tcl scripting language development environment -Name: tcl -Version: %{version} -Release: 1 -Copyright: BSD -Group: Development/Languages -Source: ftp://ftp.scriptics.com/pub/tcl/tcl8_3/tcl%{version}.tar.gz -URL: http://dev.scriptics.com/ -Packager: Scriptics Corporation -Buildroot: /var/tmp/%{name}%{version} - -%description -The Tcl (Tool Command Language) provides a powerful platform for -creating integration applications that tie together diverse -applications, protocols, devices, and frameworks. When paired with -the Tk toolkit, Tcl provides the fastest and most powerful way to -create GUI applications that run on PCs, Unix, and the Macintosh. Tcl -can also be used for a variety of web-related tasks and for creating -powerful command languages for applications. - -%prep - -%build -./configure --prefix %{directory} --exec-prefix %{directory} -make CFLAGS=$RPM_OPT_FLAGS - -%install -rm -rf $RPM_BUILD_ROOT -make INSTALL_ROOT=$RPM_BUILD_ROOT install - -%clean -rm -rf $RPM_BUILD_ROOT - -# to create the tcl files list, comment out tk in the install section above, -# then run "rpm -bi" then do a find from the build root directory, -# and remove the files in specific directories which suffice by themselves, -# then to create the files list for tk, uncomment tk, comment out tcl, -# then rm -rf $RPM_BUILD_ROOT then rpm --short-circuit -bi then redo a find, -# and remove the files in specific directories which suffice by themselves. -%files -%defattr(-,root,root) -%{directory}/lib -%{directory}/bin -%{directory}/include -%{directory}/man/man1 -%{directory}/man/man3 -%{directory}/man/mann diff --git a/unix/tclAppInit.c b/unix/tclAppInit.c deleted file mode 100644 index bc5b44c..0000000 --- a/unix/tclAppInit.c +++ /dev/null @@ -1,182 +0,0 @@ -/* - * tclAppInit.c -- - * - * Provides a default version of the main program and Tcl_AppInit - * procedure for Tcl applications (without Tk). - * - * Copyright (c) 1993 The Regents of the University of California. - * Copyright (c) 1994-1997 Sun Microsystems, Inc. - * Copyright (c) 1998-1999 by Scriptics Corporation. - * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclAppInit.c,v 1.9 2000/04/18 23:06:39 hobbs Exp $ - */ - -#include "tcl.h" - -/* - * The following variable is a special hack that is needed in order for - * Sun shared libraries to be used for Tcl. - */ - -extern int matherr(); -int *tclDummyMathPtr = (int *) matherr; - - -#ifdef TCL_TEST - -#include "tclInt.h" - -extern int Procbodytest_Init _ANSI_ARGS_((Tcl_Interp *interp)); -extern int Procbodytest_SafeInit _ANSI_ARGS_((Tcl_Interp *interp)); -extern int TclObjTest_Init _ANSI_ARGS_((Tcl_Interp *interp)); -extern int Tcltest_Init _ANSI_ARGS_((Tcl_Interp *interp)); -#ifdef TCL_THREADS -extern int TclThread_Init _ANSI_ARGS_((Tcl_Interp *interp)); -#endif - -#endif /* TCL_TEST */ - -#ifdef TCL_XT_TEST -extern void XtToolkitInitialize _ANSI_ARGS_((void)); -extern int Tclxttest_Init _ANSI_ARGS_((Tcl_Interp *interp)); -#endif - -/* - *---------------------------------------------------------------------- - * - * main -- - * - * This is the main program for the application. - * - * Results: - * None: Tcl_Main never returns here, so this procedure never - * returns either. - * - * Side effects: - * Whatever the application does. - * - *---------------------------------------------------------------------- - */ - -int -main(argc, argv) - int argc; /* Number of command-line arguments. */ - char **argv; /* Values of command-line arguments. */ -{ - /* - * The following #if block allows you to change the AppInit - * function by using a #define of TCL_LOCAL_APPINIT instead - * of rewriting this entire file. The #if checks for that - * #define and uses Tcl_AppInit if it doesn't exist. - */ - -#ifndef TCL_LOCAL_APPINIT -#define TCL_LOCAL_APPINIT Tcl_AppInit -#endif - extern int TCL_LOCAL_APPINIT _ANSI_ARGS_((Tcl_Interp *interp)); - - /* - * The following #if block allows you to change how Tcl finds the startup - * script, prime the library or encoding paths, fiddle with the argv, - * etc., without needing to rewrite Tcl_Main() - */ - -#ifdef TCL_LOCAL_MAIN_HOOK - extern int TCL_LOCAL_MAIN_HOOK _ANSI_ARGS_((int *argc, char ***argv)); -#endif - -#ifdef TCL_XT_TEST - XtToolkitInitialize(); -#endif - -#ifdef TCL_LOCAL_MAIN_HOOK - TCL_LOCAL_MAIN_HOOK(&argc, &argv); -#endif - - Tcl_Main(argc, argv, TCL_LOCAL_APPINIT); - - return 0; /* Needed only to prevent compiler warning. */ -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_AppInit -- - * - * This procedure performs application-specific initialization. - * Most applications, especially those that incorporate additional - * packages, will have their own version of this procedure. - * - * Results: - * Returns a standard Tcl completion code, and leaves an error - * message in the interp's result if an error occurs. - * - * Side effects: - * Depends on the startup script. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_AppInit(interp) - Tcl_Interp *interp; /* Interpreter for application. */ -{ - if (Tcl_Init(interp) == TCL_ERROR) { - return TCL_ERROR; - } - -#ifdef TCL_TEST -#ifdef TCL_XT_TEST - if (Tclxttest_Init(interp) == TCL_ERROR) { - return TCL_ERROR; - } -#endif - if (Tcltest_Init(interp) == TCL_ERROR) { - return TCL_ERROR; - } - Tcl_StaticPackage(interp, "Tcltest", Tcltest_Init, - (Tcl_PackageInitProc *) NULL); - if (TclObjTest_Init(interp) == TCL_ERROR) { - return TCL_ERROR; - } -#ifdef TCL_THREADS - if (TclThread_Init(interp) == TCL_ERROR) { - return TCL_ERROR; - } -#endif - if (Procbodytest_Init(interp) == TCL_ERROR) { - return TCL_ERROR; - } - Tcl_StaticPackage(interp, "procbodytest", Procbodytest_Init, - Procbodytest_SafeInit); -#endif /* TCL_TEST */ - - /* - * Call the init procedures for included packages. Each call should - * look like this: - * - * if (Mod_Init(interp) == TCL_ERROR) { - * return TCL_ERROR; - * } - * - * where "Mod" is the name of the module. - */ - - /* - * Call Tcl_CreateCommand for application-specific commands, if - * they weren't already created by the init procedures called above. - */ - - /* - * Specify a user-specific startup file to invoke if the application - * is run interactively. Typically the startup file is "~/.apprc" - * where "app" is the name of the application. If this line is deleted - * then no user-specific startup file will be run under any conditions. - */ - - Tcl_SetVar(interp, "tcl_rcFileName", "~/.tclshrc", TCL_GLOBAL_ONLY); - return TCL_OK; -} diff --git a/unix/tclConfig.sh.in b/unix/tclConfig.sh.in deleted file mode 100644 index 36df936..0000000 --- a/unix/tclConfig.sh.in +++ /dev/null @@ -1,172 +0,0 @@ -# tclConfig.sh -- -# -# This shell script (for sh) is generated automatically by Tcl's -# configure script. It will create shell variables for most of -# the configuration options discovered by the configure script. -# This script is intended to be included by the configure scripts -# for Tcl extensions so that they don't have to figure this all -# out for themselves. -# -# The information in this file is specific to a single platform. -# -# RCS: @(#) $Id: tclConfig.sh.in,v 1.13 1999/07/29 19:21:32 wart Exp $ - -# Tcl's version number. -TCL_VERSION='@TCL_VERSION@' -TCL_MAJOR_VERSION='@TCL_MAJOR_VERSION@' -TCL_MINOR_VERSION='@TCL_MINOR_VERSION@' -TCL_PATCH_LEVEL='@TCL_PATCH_LEVEL@' - -# C compiler to use for compilation. -TCL_CC='@CC@' - -# -D flags for use with the C compiler. -TCL_DEFS='@DEFS@' - -# If TCL was built with debugging symbols, generated libraries contain -# this string at the end of the library name (before the extension). -TCL_DBGX=@TCL_DBGX@ - -# Default flags used in an optimized and debuggable build, respectively. -TCL_CFLAGS_DEBUG='@CFLAGS_DEBUG@' -TCL_CFLAGS_OPTIMIZE='@CFLAGS_OPTIMIZE@' - -# Default linker flags used in an optimized and debuggable build, respectively. -TCL_LDFLAGS_DEBUG='@LDFLAGS_DEBUG@' -TCL_LDFLAGS_OPTIMIZE='@LDFLAGS_OPTIMIZE@' - -# Flag, 1: we built a shared lib, 0 we didn't -TCL_SHARED_BUILD=@TCL_SHARED_BUILD@ - -# The name of the Tcl library (may be either a .a file or a shared library): -TCL_LIB_FILE='@TCL_LIB_FILE@' - -# Flag to indicate whether shared libraries need export files. -TCL_NEEDS_EXP_FILE=@TCL_NEEDS_EXP_FILE@ - -# String that can be evaluated to generate the part of the export file -# name that comes after the "libxxx" (includes version number, if any, -# extension, and anything else needed). May depend on the variables -# VERSION. On most UNIX systems this is ${VERSION}.exp. -TCL_EXPORT_FILE_SUFFIX='@CFG_TCL_EXPORT_FILE_SUFFIX@' - -# Additional libraries to use when linking Tcl. -TCL_LIBS='@DL_LIBS@ @LIBS@ @MATH_LIBS@' - -# Top-level directory in which Tcl's platform-independent files are -# installed. -TCL_PREFIX='@prefix@' - -# Top-level directory in which Tcl's platform-specific files (e.g. -# executables) are installed. -TCL_EXEC_PREFIX='@exec_prefix@' - -# Flags to pass to cc when compiling the components of a shared library: -TCL_SHLIB_CFLAGS='@SHLIB_CFLAGS@' - -# Flags to pass to cc to get warning messages -TCL_CFLAGS_WARNING='@CFLAGS_WARNING@' - -# Extra flags to pass to cc: -TCL_EXTRA_CFLAGS='@EXTRA_CFLAGS@' - -# Base command to use for combining object files into a shared library: -TCL_SHLIB_LD='@SHLIB_LD@' - -# Base command to use for combining object files into a shared library: -TCL_STLIB_LD='@STLIB_LD@' - -# Either '$LIBS' (if dependent libraries should be included when linking -# shared libraries) or an empty string. See Tcl's configure.in for more -# explanation. -TCL_SHLIB_LD_LIBS='@SHLIB_LD_LIBS@' - -# Suffix to use for the name of a shared library. -TCL_SHLIB_SUFFIX='@SHLIB_SUFFIX@' - -# Library file(s) to include in tclsh and other base applications -# in order to provide facilities needed by DLOBJ above. -TCL_DL_LIBS='@DL_LIBS@' - -# Flags to pass to the compiler when linking object files into -# an executable tclsh or tcltest binary. -TCL_LD_FLAGS='@LDFLAGS@' - -# Flags to pass to ld, such as "-R /usr/local/tcl/lib", that tell the -# run-time dynamic linker where to look for shared libraries such as -# libtcl.so. Used when linking applications. Only works if there -# is a variable "LIB_RUNTIME_DIR" defined in the Makefile. -TCL_LD_SEARCH_FLAGS='@TCL_LD_SEARCH_FLAGS@' - -# Additional object files linked with Tcl to provide compatibility -# with standard facilities from ANSI C or POSIX. -TCL_COMPAT_OBJS='@LIBOBJS@' - -# Name of the ranlib program to use. -TCL_RANLIB='@RANLIB@' - -# -l flag to pass to the linker to pick up the Tcl library -TCL_LIB_FLAG='@TCL_LIB_FLAG@' - -# String to pass to linker to pick up the Tcl library from its -# build directory. -TCL_BUILD_LIB_SPEC='@TCL_BUILD_LIB_SPEC@' - -# String to pass to linker to pick up the Tcl library from its -# installed directory. -TCL_LIB_SPEC='@TCL_LIB_SPEC@' - -# Indicates whether a version numbers should be used in -l switches -# ("ok" means it's safe to use switches like -ltcl7.5; "nodots" means -# use switches like -ltcl75). SunOS and FreeBSD require "nodots", for -# example. -TCL_LIB_VERSIONS_OK='@TCL_LIB_VERSIONS_OK@' - -# String that can be evaluated to generate the part of a shared library -# name that comes after the "libxxx" (includes version number, if any, -# extension, and anything else needed). May depend on the variables -# VERSION and SHLIB_SUFFIX. On most UNIX systems this is -# ${VERSION}${SHLIB_SUFFIX}. -TCL_SHARED_LIB_SUFFIX='@CFG_TCL_SHARED_LIB_SUFFIX@' - -# String that can be evaluated to generate the part of an unshared library -# name that comes after the "libxxx" (includes version number, if any, -# extension, and anything else needed). May depend on the variable -# VERSION. On most UNIX systems this is ${VERSION}.a. -TCL_UNSHARED_LIB_SUFFIX='@CFG_TCL_UNSHARED_LIB_SUFFIX@' - -# Location of the top-level source directory from which Tcl was built. -# This is the directory that contains a README file as well as -# subdirectories such as generic, unix, etc. If Tcl was compiled in a -# different place than the directory containing the source files, this -# points to the location of the sources, not the location where Tcl was -# compiled. -TCL_SRC_DIR='@TCL_SRC_DIR@' - -# List of standard directories in which to look for packages during -# "package require" commands. Contains the "prefix" directory plus also -# the "exec_prefix" directory, if it is different. -TCL_PACKAGE_PATH='@TCL_PACKAGE_PATH@' - -# Tcl supports stub. -TCL_SUPPORTS_STUBS=1 - -# The name of the Tcl stub library (.a): -TCL_STUB_LIB_FILE='@TCL_STUB_LIB_FILE@' - -# -l flag to pass to the linker to pick up the Tcl stub library -TCL_STUB_LIB_FLAG='@TCL_STUB_LIB_FLAG@' - -# String to pass to linker to pick up the Tcl stub library from its -# build directory. -TCL_BUILD_STUB_LIB_SPEC='@TCL_BUILD_STUB_LIB_SPEC@' - -# String to pass to linker to pick up the Tcl stub library from its -# installed directory. -TCL_STUB_LIB_SPEC='@TCL_STUB_LIB_SPEC@' - -# Path to the Tcl stub library in the build directory. -TCL_BUILD_STUB_LIB_PATH='@TCL_BUILD_STUB_LIB_PATH@' - -# Path to the Tcl stub library in the install directory. -TCL_STUB_LIB_PATH='@TCL_STUB_LIB_PATH@' diff --git a/unix/tclLoadAix.c b/unix/tclLoadAix.c deleted file mode 100644 index 8fe28a1..0000000 --- a/unix/tclLoadAix.c +++ /dev/null @@ -1,549 +0,0 @@ -/* - * tclLoadAix.c -- - * - * This file implements the dlopen and dlsym APIs under the - * AIX operating system, to enable the Tcl "load" command to - * work. This code was provided by Jens-Uwe Mager. - * - * This file is subject to the following copyright notice, which is - * different from the notice used elsewhere in Tcl. The file has - * been modified to incorporate the file dlfcn.h in-line. - * - * Copyright (c) 1992,1993,1995,1996, Jens-Uwe Mager, Helios Software GmbH - * Not derived from licensed software. - - * Permission is granted to freely use, copy, modify, and redistribute - * this software, provided that the author is not construed to be liable - * for any results of using the software, alterations are clearly marked - * as such, and this notice is not modified. - * - * RCS: @(#) $Id: tclLoadAix.c,v 1.3 1999/04/16 00:48:04 stanton Exp $ - * - * Note: this file has been altered from the original in a few - * ways in order to work properly with Tcl. - */ - -/* - * @(#)dlfcn.c 1.7 revision of 95/08/14 19:08:38 - * This is an unpublished work copyright (c) 1992 HELIOS Software GmbH - * 30159 Hannover, Germany - */ - -#include <stdio.h> -#include <errno.h> -#include <string.h> -#include <stdlib.h> -#include <sys/types.h> -#include <sys/ldr.h> -#include <a.out.h> -#include <ldfcn.h> -#include "../compat/dlfcn.h" - -/* - * We simulate dlopen() et al. through a call to load. Because AIX has - * no call to find an exported symbol we read the loader section of the - * loaded module and build a list of exported symbols and their virtual - * address. - */ - -typedef struct { - char *name; /* the symbols's name */ - void *addr; /* its relocated virtual address */ -} Export, *ExportPtr; - -/* - * xlC uses the following structure to list its constructors and - * destructors. This is gleaned from the output of munch. - */ -typedef struct { - void (*init)(void); /* call static constructors */ - void (*term)(void); /* call static destructors */ -} Cdtor, *CdtorPtr; - -/* - * The void * handle returned from dlopen is actually a ModulePtr. - */ -typedef struct Module { - struct Module *next; - char *name; /* module name for refcounting */ - int refCnt; /* the number of references */ - void *entry; /* entry point from load */ - struct dl_info *info; /* optional init/terminate functions */ - CdtorPtr cdtors; /* optional C++ constructors */ - int nExports; /* the number of exports found */ - ExportPtr exports; /* the array of exports */ -} Module, *ModulePtr; - -/* - * We keep a list of all loaded modules to be able to call the fini - * handlers and destructors at atexit() time. - */ -static ModulePtr modList; - -/* - * The last error from one of the dl* routines is kept in static - * variables here. Each error is returned only once to the caller. - */ -static char errbuf[BUFSIZ]; -static int errvalid; - -static void caterr(char *); -static int readExports(ModulePtr); -static void terminate(void); -static void *findMain(void); - -VOID *dlopen(const char *path, int mode) -{ - register ModulePtr mp; - static void *mainModule; - - /* - * Upon the first call register a terminate handler that will - * close all libraries. Also get a reference to the main module - * for use with loadbind. - */ - if (!mainModule) { - if ((mainModule = findMain()) == NULL) - return NULL; - atexit(terminate); - } - /* - * Scan the list of modules if we have the module already loaded. - */ - for (mp = modList; mp; mp = mp->next) - if (strcmp(mp->name, path) == 0) { - mp->refCnt++; - return (VOID *) mp; - } - if ((mp = (ModulePtr)calloc(1, sizeof(*mp))) == NULL) { - errvalid++; - strcpy(errbuf, "calloc: "); - strcat(errbuf, strerror(errno)); - return (VOID *) NULL; - } - mp->name = malloc((unsigned) (strlen(path) + 1)); - strcpy(mp->name, path); - /* - * load should be declared load(const char *...). Thus we - * cast the path to a normal char *. Ugly. - */ - if ((mp->entry = (void *)load((char *)path, L_NOAUTODEFER, NULL)) == NULL) { - free(mp->name); - free(mp); - errvalid++; - strcpy(errbuf, "dlopen: "); - strcat(errbuf, path); - strcat(errbuf, ": "); - /* - * If AIX says the file is not executable, the error - * can be further described by querying the loader about - * the last error. - */ - if (errno == ENOEXEC) { - char *tmp[BUFSIZ/sizeof(char *)]; - if (loadquery(L_GETMESSAGES, tmp, sizeof(tmp)) == -1) - strcpy(errbuf, strerror(errno)); - else { - char **p; - for (p = tmp; *p; p++) - caterr(*p); - } - } else - strcat(errbuf, strerror(errno)); - return (VOID *) NULL; - } - mp->refCnt = 1; - mp->next = modList; - modList = mp; - if (loadbind(0, mainModule, mp->entry) == -1) { - dlclose(mp); - errvalid++; - strcpy(errbuf, "loadbind: "); - strcat(errbuf, strerror(errno)); - return (VOID *) NULL; - } - /* - * If the user wants global binding, loadbind against all other - * loaded modules. - */ - if (mode & RTLD_GLOBAL) { - register ModulePtr mp1; - for (mp1 = mp->next; mp1; mp1 = mp1->next) - if (loadbind(0, mp1->entry, mp->entry) == -1) { - dlclose(mp); - errvalid++; - strcpy(errbuf, "loadbind: "); - strcat(errbuf, strerror(errno)); - return (VOID *) NULL; - } - } - if (readExports(mp) == -1) { - dlclose(mp); - return (VOID *) NULL; - } - /* - * If there is a dl_info structure, call the init function. - */ - if (mp->info = (struct dl_info *)dlsym(mp, "dl_info")) { - if (mp->info->init) - (*mp->info->init)(); - } else - errvalid = 0; - /* - * If the shared object was compiled using xlC we will need - * to call static constructors (and later on dlclose destructors). - */ - if (mp->cdtors = (CdtorPtr)dlsym(mp, "__cdtors")) { - while (mp->cdtors->init) { - (*mp->cdtors->init)(); - mp->cdtors++; - } - } else - errvalid = 0; - return (VOID *) mp; -} - -/* - * Attempt to decipher an AIX loader error message and append it - * to our static error message buffer. - */ -static void caterr(char *s) -{ - register char *p = s; - - while (*p >= '0' && *p <= '9') - p++; - switch(atoi(s)) { /* INTL: "C", UTF safe. */ - case L_ERROR_TOOMANY: - strcat(errbuf, "to many errors"); - break; - case L_ERROR_NOLIB: - strcat(errbuf, "can't load library"); - strcat(errbuf, p); - break; - case L_ERROR_UNDEF: - strcat(errbuf, "can't find symbol"); - strcat(errbuf, p); - break; - case L_ERROR_RLDBAD: - strcat(errbuf, "bad RLD"); - strcat(errbuf, p); - break; - case L_ERROR_FORMAT: - strcat(errbuf, "bad exec format in"); - strcat(errbuf, p); - break; - case L_ERROR_ERRNO: - strcat(errbuf, strerror(atoi(++p))); /* INTL: "C", UTF safe. */ - break; - default: - strcat(errbuf, s); - break; - } -} - -VOID *dlsym(void *handle, const char *symbol) -{ - register ModulePtr mp = (ModulePtr)handle; - register ExportPtr ep; - register int i; - - /* - * Could speed up the search, but I assume that one assigns - * the result to function pointers anyways. - */ - for (ep = mp->exports, i = mp->nExports; i; i--, ep++) - if (strcmp(ep->name, symbol) == 0) - return ep->addr; - errvalid++; - strcpy(errbuf, "dlsym: undefined symbol "); - strcat(errbuf, symbol); - return NULL; -} - -char *dlerror(void) -{ - if (errvalid) { - errvalid = 0; - return errbuf; - } - return NULL; -} - -int dlclose(void *handle) -{ - register ModulePtr mp = (ModulePtr)handle; - int result; - register ModulePtr mp1; - - if (--mp->refCnt > 0) - return 0; - if (mp->info && mp->info->fini) - (*mp->info->fini)(); - if (mp->cdtors) - while (mp->cdtors->term) { - (*mp->cdtors->term)(); - mp->cdtors++; - } - result = unload(mp->entry); - if (result == -1) { - errvalid++; - strcpy(errbuf, strerror(errno)); - } - if (mp->exports) { - register ExportPtr ep; - register int i; - for (ep = mp->exports, i = mp->nExports; i; i--, ep++) - if (ep->name) - free(ep->name); - free(mp->exports); - } - if (mp == modList) - modList = mp->next; - else { - for (mp1 = modList; mp1; mp1 = mp1->next) - if (mp1->next == mp) { - mp1->next = mp->next; - break; - } - } - free(mp->name); - free(mp); - return result; -} - -static void terminate(void) -{ - while (modList) - dlclose(modList); -} - -/* - * Build the export table from the XCOFF .loader section. - */ -static int readExports(ModulePtr mp) -{ - LDFILE *ldp = NULL; - SCNHDR sh, shdata; - LDHDR *lhp; - char *ldbuf; - LDSYM *ls; - int i; - ExportPtr ep; - - if ((ldp = ldopen(mp->name, ldp)) == NULL) { - struct ld_info *lp; - char *buf; - int size = 4*1024; - if (errno != ENOENT) { - errvalid++; - strcpy(errbuf, "readExports: "); - strcat(errbuf, strerror(errno)); - return -1; - } - /* - * The module might be loaded due to the LIBPATH - * environment variable. Search for the loaded - * module using L_GETINFO. - */ - if ((buf = malloc(size)) == NULL) { - errvalid++; - strcpy(errbuf, "readExports: "); - strcat(errbuf, strerror(errno)); - return -1; - } - while ((i = loadquery(L_GETINFO, buf, size)) == -1 && errno == ENOMEM) { - free(buf); - size += 4*1024; - if ((buf = malloc(size)) == NULL) { - errvalid++; - strcpy(errbuf, "readExports: "); - strcat(errbuf, strerror(errno)); - return -1; - } - } - if (i == -1) { - errvalid++; - strcpy(errbuf, "readExports: "); - strcat(errbuf, strerror(errno)); - free(buf); - return -1; - } - /* - * Traverse the list of loaded modules. The entry point - * returned by load() does actually point to the data - * segment origin. - */ - lp = (struct ld_info *)buf; - while (lp) { - if (lp->ldinfo_dataorg == mp->entry) { - ldp = ldopen(lp->ldinfo_filename, ldp); - break; - } - if (lp->ldinfo_next == 0) - lp = NULL; - else - lp = (struct ld_info *)((char *)lp + lp->ldinfo_next); - } - free(buf); - if (!ldp) { - errvalid++; - strcpy(errbuf, "readExports: "); - strcat(errbuf, strerror(errno)); - return -1; - } - } - if (TYPE(ldp) != U802TOCMAGIC) { - errvalid++; - strcpy(errbuf, "readExports: bad magic"); - while(ldclose(ldp) == FAILURE) - ; - return -1; - } - /* - * Get the padding for the data section. This is needed for - * AIX 4.1 compilers. This is used when building the final - * function pointer to the exported symbol. - */ - if (ldnshread(ldp, _DATA, &shdata) != SUCCESS) { - errvalid++; - strcpy(errbuf, "readExports: cannot read data section header"); - while(ldclose(ldp) == FAILURE) - ; - return -1; - } - if (ldnshread(ldp, _LOADER, &sh) != SUCCESS) { - errvalid++; - strcpy(errbuf, "readExports: cannot read loader section header"); - while(ldclose(ldp) == FAILURE) - ; - return -1; - } - /* - * We read the complete loader section in one chunk, this makes - * finding long symbol names residing in the string table easier. - */ - if ((ldbuf = (char *)malloc(sh.s_size)) == NULL) { - errvalid++; - strcpy(errbuf, "readExports: "); - strcat(errbuf, strerror(errno)); - while(ldclose(ldp) == FAILURE) - ; - return -1; - } - if (FSEEK(ldp, sh.s_scnptr, BEGINNING) != OKFSEEK) { - errvalid++; - strcpy(errbuf, "readExports: cannot seek to loader section"); - free(ldbuf); - while(ldclose(ldp) == FAILURE) - ; - return -1; - } - if (FREAD(ldbuf, sh.s_size, 1, ldp) != 1) { - errvalid++; - strcpy(errbuf, "readExports: cannot read loader section"); - free(ldbuf); - while(ldclose(ldp) == FAILURE) - ; - return -1; - } - lhp = (LDHDR *)ldbuf; - ls = (LDSYM *)(ldbuf+LDHDRSZ); - /* - * Count the number of exports to include in our export table. - */ - for (i = lhp->l_nsyms; i; i--, ls++) { - if (!LDR_EXPORT(*ls)) - continue; - mp->nExports++; - } - if ((mp->exports = (ExportPtr)calloc(mp->nExports, sizeof(*mp->exports))) == NULL) { - errvalid++; - strcpy(errbuf, "readExports: "); - strcat(errbuf, strerror(errno)); - free(ldbuf); - while(ldclose(ldp) == FAILURE) - ; - return -1; - } - /* - * Fill in the export table. All entries are relative to - * the entry point we got from load. - */ - ep = mp->exports; - ls = (LDSYM *)(ldbuf+LDHDRSZ); - for (i = lhp->l_nsyms; i; i--, ls++) { - char *symname; - char tmpsym[SYMNMLEN+1]; - if (!LDR_EXPORT(*ls)) - continue; - if (ls->l_zeroes == 0) - symname = ls->l_offset+lhp->l_stoff+ldbuf; - else { - /* - * The l_name member is not zero terminated, we - * must copy the first SYMNMLEN chars and make - * sure we have a zero byte at the end. - */ - strncpy(tmpsym, ls->l_name, SYMNMLEN); - tmpsym[SYMNMLEN] = '\0'; - symname = tmpsym; - } - ep->name = malloc((unsigned) (strlen(symname) + 1)); - strcpy(ep->name, symname); - ep->addr = (void *)((unsigned long)mp->entry + - ls->l_value - shdata.s_vaddr); - ep++; - } - free(ldbuf); - while(ldclose(ldp) == FAILURE) - ; - return 0; -} - -/* - * Find the main modules entry point. This is used as export pointer - * for loadbind() to be able to resolve references to the main part. - */ -static void * findMain(void) -{ - struct ld_info *lp; - char *buf; - int size = 4*1024; - int i; - void *ret; - - if ((buf = malloc(size)) == NULL) { - errvalid++; - strcpy(errbuf, "findMain: "); - strcat(errbuf, strerror(errno)); - return NULL; - } - while ((i = loadquery(L_GETINFO, buf, size)) == -1 && errno == ENOMEM) { - free(buf); - size += 4*1024; - if ((buf = malloc(size)) == NULL) { - errvalid++; - strcpy(errbuf, "findMain: "); - strcat(errbuf, strerror(errno)); - return NULL; - } - } - if (i == -1) { - errvalid++; - strcpy(errbuf, "findMain: "); - strcat(errbuf, strerror(errno)); - free(buf); - return NULL; - } - /* - * The first entry is the main module. The entry point - * returned by load() does actually point to the data - * segment origin. - */ - lp = (struct ld_info *)buf; - ret = lp->ldinfo_dataorg; - free(buf); - return ret; -} - diff --git a/unix/tclLoadAout.c b/unix/tclLoadAout.c deleted file mode 100644 index da85d16..0000000 --- a/unix/tclLoadAout.c +++ /dev/null @@ -1,507 +0,0 @@ -/* - * tclLoadAout.c -- - * - * This procedure provides a version of the TclLoadFile that - * provides pseudo-static linking using version-7 compatible - * a.out files described in either sys/exec.h or sys/a.out.h. - * - * Copyright (c) 1995, by General Electric Company. All rights reserved. - * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * This work was supported in part by the ARPA Manufacturing Automation - * and Design Engineering (MADE) Initiative through ARPA contract - * F33615-94-C-4400. - * - * RCS: @(#) $Id: tclLoadAout.c,v 1.4 2000/03/27 18:34:32 ericm Exp $ - */ - -#include "tclInt.h" -#include <fcntl.h> -#ifdef HAVE_EXEC_AOUT_H -# include <sys/exec_aout.h> -#endif - -/* - * Some systems describe the a.out header in sys/exec.h, and some in - * a.out.h. - */ - -#ifdef USE_SYS_EXEC_H -#include <sys/exec.h> -#endif -#ifdef USE_A_OUT_H -#include <a.out.h> -#endif -#ifdef USE_SYS_EXEC_AOUT_H -#include <sys/exec_aout.h> -#define a_magic a_midmag -#endif - -/* - * TCL_LOADSHIM is the amount by which to shim the break when loading - */ - -#ifndef TCL_LOADSHIM -#define TCL_LOADSHIM 0x4000L -#endif - -/* - * TCL_LOADALIGN must be a power of 2, and is the alignment to which - * to force the origin of load modules - */ - -#ifndef TCL_LOADALIGN -#define TCL_LOADALIGN 0x4000L -#endif - -/* - * TCL_LOADMAX is the maximum size of a load module, and is used as - * a sanity check when loading - */ - -#ifndef TCL_LOADMAX -#define TCL_LOADMAX 2000000L -#endif - -/* - * Kernel calls that appear to be missing from the system .h files: - */ - -extern char * brk _ANSI_ARGS_((char *)); -extern char * sbrk _ANSI_ARGS_((size_t)); - -/* - * The static variable SymbolTableFile contains the file name where the - * result of the last link was stored. The file is kept because doing so - * allows one load module to use the symbols defined in another. - */ - -static char * SymbolTableFile = NULL; - -/* - * Type of the dictionary function that begins each load module. - */ - -typedef Tcl_PackageInitProc * (* DictFn) _ANSI_ARGS_ ((char * symbol)); - -/* - * Prototypes for procedures referenced only in this file: - */ - -static int FindLibraries _ANSI_ARGS_((Tcl_Interp * interp, char * fileName, - Tcl_DString * buf)); -static void UnlinkSymbolTable _ANSI_ARGS_((void)); - -/* - *---------------------------------------------------------------------- - * - * TclpLoadFile -- - * - * Dynamically loads a binary code file into memory and returns - * the addresses of two procedures within that file, if they - * are defined. - * - * Results: - * A standard Tcl completion code. If an error occurs, an error - * message is left in the interp's result. *proc1Ptr and *proc2Ptr - * are filled in with the addresses of the symbols given by - * *sym1 and *sym2, or NULL if those symbols can't be found. - * - * Side effects: - * New code suddenly appears in memory. - * - * - * Bugs: - * This function does not attempt to handle the case where the - * BSS segment is not executable. It will therefore fail on - * Encore Multimax, Pyramid 90x, and similar machines. The - * reason is that the mprotect() kernel call, which would - * otherwise be employed to mark the newly-loaded text segment - * executable, results in a system crash on BSD/386. - * - * In an effort to make it fast, this function eschews the - * technique of linking the load module once, reading its header - * to determine its size, allocating memory for it, and linking - * it again. Instead, it `shims out' memory allocation by - * placing the module TCL_LOADSHIM bytes beyond the break, - * and assuming that any malloc() calls required to run the - * linker will not advance the break beyond that point. If - * the break is advanced beyonnd that point, the load will - * fail with an `inconsistent memory allocation' error. - * It perhaps ought to retry the link, but the failure has - * not been observed in two years of daily use of this function. - *---------------------------------------------------------------------- - */ - -int -TclpLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr, clientDataPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - char *fileName; /* Name of the file containing the desired - * code (UTF-8). */ - char *sym1, *sym2; /* Names of two procedures to look up in - * the file's symbol table. */ - Tcl_PackageInitProc **proc1Ptr, **proc2Ptr; - /* Where to return the addresses corresponding - * to sym1 and sym2. */ - ClientData *clientDataPtr; /* Filled with token for dynamically loaded - * file which will be passed back to - * TclpUnloadFile() to unload the file. */ -{ - char * inputSymbolTable; /* Name of the file containing the - * symbol table from the last link. */ - Tcl_DString linkCommandBuf; /* Command to do the run-time relocation - * of the module.*/ - char * linkCommand; - char relocatedFileName [L_tmpnam]; - /* Name of the file holding the relocated */ - /* text of the module */ - int relocatedFd; /* File descriptor of the file holding - * relocated text */ - struct exec relocatedHead; /* Header of the relocated text */ - unsigned long relocatedSize; /* Size of the relocated text */ - char * startAddress; /* Starting address of the module */ - DictFn dictionary; /* Dictionary function in the load module */ - int status; /* Status return from Tcl_ calls */ - char * p; - - *clientDataPtr = NULL; - - /* Find the file that contains the symbols for the run-time link. */ - - if (SymbolTableFile != NULL) { - inputSymbolTable = SymbolTableFile; - } else if (tclExecutableName == NULL) { - Tcl_SetResult (interp, "can't find the tclsh executable", TCL_STATIC); - return TCL_ERROR; - } else { - inputSymbolTable = tclExecutableName; - } - - /* Construct the `ld' command that builds the relocated module */ - - tmpnam (relocatedFileName); - Tcl_DStringInit (&linkCommandBuf); - Tcl_DStringAppend (&linkCommandBuf, "exec ld -o ", -1); - Tcl_DStringAppend (&linkCommandBuf, relocatedFileName, -1); -#if defined(__mips) || defined(mips) - Tcl_DStringAppend (&linkCommandBuf, " -G 0 ", -1); -#endif - Tcl_DStringAppend (&linkCommandBuf, " -u TclLoadDictionary_", -1); - TclGuessPackageName(fileName, &linkCommandBuf); - Tcl_DStringAppend (&linkCommandBuf, " -A ", -1); - Tcl_DStringAppend (&linkCommandBuf, inputSymbolTable, -1); - Tcl_DStringAppend (&linkCommandBuf, " -N -T XXXXXXXX ", -1); - Tcl_DStringAppend (&linkCommandBuf, fileName, -1); - Tcl_DStringAppend (&linkCommandBuf, " ", -1); - if (FindLibraries (interp, fileName, &linkCommandBuf) != TCL_OK) { - Tcl_DStringFree (&linkCommandBuf); - return TCL_ERROR; - } - linkCommand = Tcl_DStringValue (&linkCommandBuf); - - /* Determine the starting address, and plug it into the command */ - - startAddress = (char *) (((unsigned long) sbrk (0) - + TCL_LOADSHIM + TCL_LOADALIGN - 1) - & (- TCL_LOADALIGN)); - p = strstr (linkCommand, "-T") + 3; - sprintf (p, "%08lx", (long) startAddress); - p [8] = ' '; - - /* Run the linker */ - - status = Tcl_Eval (interp, linkCommand); - Tcl_DStringFree (&linkCommandBuf); - if (status != 0) { - return TCL_ERROR; - } - - /* Open the linker's result file and read the header */ - - relocatedFd = open (relocatedFileName, O_RDONLY); - if (relocatedFd < 0) { - goto ioError; - } - status= read (relocatedFd, (char *) & relocatedHead, sizeof relocatedHead); - if (status < sizeof relocatedHead) { - goto ioError; - } - - /* Check the magic number */ - - if (relocatedHead.a_magic != OMAGIC) { - Tcl_AppendResult (interp, "bad magic number in intermediate file \"", - relocatedFileName, "\"", (char *) NULL); - goto failure; - } - - /* Make sure that memory allocation is still consistent */ - - if ((unsigned long) sbrk (0) > (unsigned long) startAddress) { - Tcl_SetResult (interp, "can't load, memory allocation is inconsistent.", - TCL_STATIC); - goto failure; - } - - /* Make sure that the relocated module's size is reasonable */ - - relocatedSize = relocatedHead.a_text + relocatedHead.a_data - + relocatedHead.a_bss; - if (relocatedSize > TCL_LOADMAX) { - Tcl_SetResult (interp, "module too big to load", TCL_STATIC); - goto failure; - } - - /* Advance the break to protect the loaded module */ - - (void) brk (startAddress + relocatedSize); - - /* Seek to the start of the module's text */ - -#if defined(__mips) || defined(mips) - status = lseek (relocatedFd, - (off_t) N_TXTOFF (relocatedHead.ex_f, relocatedHead.ex_o), - SEEK_SET); -#else - status = lseek (relocatedFd, (off_t) N_TXTOFF (relocatedHead), SEEK_SET); -#endif - if (status < 0) { - goto ioError; - } - - /* Read in the module's text and data */ - - relocatedSize = relocatedHead.a_text + relocatedHead.a_data; - if (read (relocatedFd, startAddress, relocatedSize) < relocatedSize) { - brk (startAddress); - ioError: - Tcl_AppendResult (interp, "error on intermediate file \"", - relocatedFileName, "\": ", Tcl_PosixError (interp), - (char *) NULL); - failure: - (void) unlink (relocatedFileName); - return TCL_ERROR; - } - - /* Close the intermediate file. */ - - (void) close (relocatedFd); - - /* Arrange things so that intermediate symbol tables eventually get - * deleted. */ - - if (SymbolTableFile != NULL) { - UnlinkSymbolTable (); - } else { - atexit (UnlinkSymbolTable); - } - SymbolTableFile = ckalloc (strlen (relocatedFileName) + 1); - strcpy (SymbolTableFile, relocatedFileName); - - /* Look up the entry points in the load module's dictionary. */ - - dictionary = (DictFn) startAddress; - *proc1Ptr = dictionary (sym1); - *proc2Ptr = dictionary (sym2); - - return TCL_OK; -} - -/* - *------------------------------------------------------------------------ - * - * FindLibraries -- - * - * Find the libraries needed to link a load module at run time. - * - * Results: - * A standard Tcl completion code. If an error occurs, - * an error message is left in the interp's result. The -l and -L - * flags are concatenated onto the dynamic string `buf'. - * - *------------------------------------------------------------------------ - */ - -static int -FindLibraries (interp, fileName, buf) - Tcl_Interp * interp; /* Used for error reporting */ - char * fileName; /* Name of the load module */ - Tcl_DString * buf; /* Buffer where the -l an -L flags */ -{ - FILE * f; /* The load module */ - int c; /* Byte from the load module */ - char * p; - Tcl_DString ds; - CONST char *native; - - /* Open the load module */ - - native = Tcl_UtfToExternalDString(NULL, fileName, -1, &ds); - f = fopen(native, "rb"); /* INTL: Native. */ - Tcl_DStringFree(&ds); - - if (f == NULL) { - Tcl_AppendResult (interp, "couldn't open \"", fileName, "\": ", - Tcl_PosixError (interp), (char *) NULL); - return TCL_ERROR; - } - - /* Search for the library list in the load module */ - - p = "@LIBS: "; - while (*p != '\0' && (c = getc (f)) != EOF) { - if (c == *p) { - ++p; - } - else { - p = "@LIBS: "; - if (c == *p) { - ++p; - } - } - } - - /* No library list -- this must be an ill-formed module */ - - if (c == EOF) { - Tcl_AppendResult (interp, "File \"", fileName, - "\" is not a Tcl load module.", (char *) NULL); - (void) fclose (f); - return TCL_ERROR; - } - - /* Accumulate the library list */ - - while ((c = getc (f)) != '\0' && c != EOF) { - char cc = c; - Tcl_DStringAppend (buf, &cc, 1); - } - (void) fclose (f); - - if (c == EOF) { - Tcl_AppendResult (interp, "Library directory in \"", fileName, - "\" ends prematurely.", (char *) NULL); - return TCL_ERROR; - } - - return TCL_OK; -} - -/* - *------------------------------------------------------------------------ - * - * UnlinkSymbolTable -- - * - * Remove the symbol table file from the last dynamic link. - * - * Results: - * None. - * - * Side effects: - * The symbol table file from the last dynamic link is removed. - * This function is called when (a) a new symbol table is present - * because another dynamic link is complete, or (b) the process - * is exiting. - *------------------------------------------------------------------------ - */ - -static void -UnlinkSymbolTable () -{ - (void) unlink (SymbolTableFile); - ckfree (SymbolTableFile); - SymbolTableFile = NULL; -} - -/* - *---------------------------------------------------------------------- - * - * TclpUnloadFile -- - * - * Unloads a dynamically loaded binary code file from memory. - * Code pointers in the formerly loaded file are no longer valid - * after calling this function. - * - * Results: - * None. - * - * Side effects: - * Does nothing. Can anything be done? - * - *---------------------------------------------------------------------- - */ - -void -TclpUnloadFile(clientData) - ClientData clientData; /* ClientData returned by a previous call - * to TclpLoadFile(). The clientData is - * a token that represents the loaded - * file. */ -{ -} - -/* - *---------------------------------------------------------------------- - * - * TclGuessPackageName -- - * - * If the "load" command is invoked without providing a package - * name, this procedure is invoked to try to figure it out. - * - * Results: - * Always returns 0 to indicate that we couldn't figure out a - * package name; generic code will then try to guess the package - * from the file name. A return value of 1 would have meant that - * we figured out the package name and put it in bufPtr. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -TclGuessPackageName(fileName, bufPtr) - char *fileName; /* Name of file containing package (already - * translated to local form if needed). */ - Tcl_DString *bufPtr; /* Initialized empty dstring. Append - * package name to this if possible. */ -{ - char *p, *q, *r; - int srcOff, dstOff; - - if (q = strrchr(fileName,'/')) { - q++; - } else { - q = fileName; - } - if (!strncmp(q,"lib",3)) { - q+=3; - } - p = q; - while ((*p) && (*p != '.') && ((*p<'0') || (*p>'9'))) { - p++; - } - if ((p>q+2) && !strncmp(p-2,"_G0.",4)) { - p-=2; - } - if (p<q) { - return 0; - } - - Tcl_DStringAppend(bufPtr,q, p-q); - - r = Tcl_DStringValue(bufPtr); - r += strlen(r) - (p-q); - - /* - * Capitalize the string and then recompute the length. - */ - - Tcl_UtfToTitle(r); - Tcl_DStringSetLength(bufPtr, strlen(Tcl_DStringValue(bufPtr))); - - return 1; -} diff --git a/unix/tclLoadDl.c b/unix/tclLoadDl.c deleted file mode 100644 index 2a868d8..0000000 --- a/unix/tclLoadDl.c +++ /dev/null @@ -1,183 +0,0 @@ -/* - * tclLoadDl.c -- - * - * This procedure provides a version of the TclLoadFile that - * works with the "dlopen" and "dlsym" library procedures for - * dynamic loading. - * - * Copyright (c) 1995-1997 Sun Microsystems, Inc. - * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclLoadDl.c,v 1.3 1999/04/16 00:48:04 stanton Exp $ - */ - -#include "tclInt.h" -#ifdef NO_DLFCN_H -# include "../compat/dlfcn.h" -#else -# include <dlfcn.h> -#endif - -/* - * In some systems, like SunOS 4.1.3, the RTLD_NOW flag isn't defined - * and this argument to dlopen must always be 1. The RTLD_GLOBAL - * flag is needed on some systems (e.g. SCO and UnixWare) but doesn't - * exist on others; if it doesn't exist, set it to 0 so it has no effect. - */ - -#ifndef RTLD_NOW -# define RTLD_NOW 1 -#endif - -#ifndef RTLD_GLOBAL -# define RTLD_GLOBAL 0 -#endif - -/* - *--------------------------------------------------------------------------- - * - * TclpLoadFile -- - * - * Dynamically loads a binary code file into memory and returns - * the addresses of two procedures within that file, if they - * are defined. - * - * Results: - * A standard Tcl completion code. If an error occurs, an error - * message is left in the interp's result. *proc1Ptr and *proc2Ptr - * are filled in with the addresses of the symbols given by - * *sym1 and *sym2, or NULL if those symbols can't be found. - * - * Side effects: - * New code suddenly appears in memory. - * - *--------------------------------------------------------------------------- - */ - -int -TclpLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr, clientDataPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - char *fileName; /* Name of the file containing the desired - * code. */ - char *sym1, *sym2; /* Names of two procedures to look up in - * the file's symbol table. */ - Tcl_PackageInitProc **proc1Ptr, **proc2Ptr; - /* Where to return the addresses corresponding - * to sym1 and sym2. */ - ClientData *clientDataPtr; /* Filled with token for dynamically loaded - * file which will be passed back to - * TclpUnloadFile() to unload the file. */ -{ - VOID *handle; - Tcl_DString newName, ds; - char *native; - - native = Tcl_UtfToExternalDString(NULL, fileName, -1, &ds); - handle = dlopen(native, RTLD_NOW | RTLD_GLOBAL); /* INTL: Native. */ - Tcl_DStringFree(&ds); - - *clientDataPtr = (ClientData) handle; - - if (handle == NULL) { - Tcl_AppendResult(interp, "couldn't load file \"", fileName, - "\": ", dlerror(), (char *) NULL); - return TCL_ERROR; - } - - /* - * Some platforms still add an underscore to the beginning of symbol - * names. If we can't find a name without an underscore, try again - * with the underscore. - */ - - native = Tcl_UtfToExternalDString(NULL, sym1, -1, &ds); - *proc1Ptr = (Tcl_PackageInitProc *) dlsym(handle, /* INTL: Native. */ - native); - if (*proc1Ptr == NULL) { - Tcl_DStringInit(&newName); - Tcl_DStringAppend(&newName, "_", 1); - native = Tcl_DStringAppend(&newName, native, -1); - *proc1Ptr = (Tcl_PackageInitProc *) dlsym(handle, /* INTL: Native. */ - native); - Tcl_DStringFree(&newName); - } - Tcl_DStringFree(&ds); - - native = Tcl_UtfToExternalDString(NULL, sym2, -1, &ds); - *proc2Ptr = (Tcl_PackageInitProc *) dlsym(handle, /* INTL: Native. */ - native); - if (*proc2Ptr == NULL) { - Tcl_DStringInit(&newName); - Tcl_DStringAppend(&newName, "_", 1); - native = Tcl_DStringAppend(&newName, native, -1); - *proc2Ptr = (Tcl_PackageInitProc *) dlsym(handle, /* INTL: Native. */ - native); - Tcl_DStringFree(&newName); - } - Tcl_DStringFree(&ds); - - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclpUnloadFile -- - * - * Unloads a dynamically loaded binary code file from memory. - * Code pointers in the formerly loaded file are no longer valid - * after calling this function. - * - * Results: - * None. - * - * Side effects: - * Code removed from memory. - * - *---------------------------------------------------------------------- - */ - -void -TclpUnloadFile(clientData) - ClientData clientData; /* ClientData returned by a previous call - * to TclpLoadFile(). The clientData is - * a token that represents the loaded - * file. */ -{ - VOID *handle; - - handle = (VOID *) clientData; - dlclose(handle); -} - -/* - *---------------------------------------------------------------------- - * - * TclGuessPackageName -- - * - * If the "load" command is invoked without providing a package - * name, this procedure is invoked to try to figure it out. - * - * Results: - * Always returns 0 to indicate that we couldn't figure out a - * package name; generic code will then try to guess the package - * from the file name. A return value of 1 would have meant that - * we figured out the package name and put it in bufPtr. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -TclGuessPackageName(fileName, bufPtr) - char *fileName; /* Name of file containing package (already - * translated to local form if needed). */ - Tcl_DString *bufPtr; /* Initialized empty dstring. Append - * package name to this if possible. */ -{ - return 0; -} diff --git a/unix/tclLoadDld.c b/unix/tclLoadDld.c deleted file mode 100644 index 1f9e702..0000000 --- a/unix/tclLoadDld.c +++ /dev/null @@ -1,162 +0,0 @@ -/* - * tclLoadDld.c -- - * - * This procedure provides a version of the TclLoadFile that - * works with the "dld_link" and "dld_get_func" library procedures - * for dynamic loading. It has been tested on Linux 1.1.95 and - * dld-3.2.7. This file probably isn't needed anymore, since it - * makes more sense to use "dl_open" etc. - * - * Copyright (c) 1995-1997 Sun Microsystems, Inc. - * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclLoadDld.c,v 1.3 1999/04/16 00:48:04 stanton Exp $ - */ - -#include "tclInt.h" -#include "dld.h" - -/* - * In some systems, like SunOS 4.1.3, the RTLD_NOW flag isn't defined - * and this argument to dlopen must always be 1. - */ - -#ifndef RTLD_NOW -# define RTLD_NOW 1 -#endif - -/* - *---------------------------------------------------------------------- - * - * TclpLoadFile -- - * - * Dynamically loads a binary code file into memory and returns - * the addresses of two procedures within that file, if they - * are defined. - * - * Results: - * A standard Tcl completion code. If an error occurs, an error - * message is left in the interp's result. *proc1Ptr and *proc2Ptr - * are filled in with the addresses of the symbols given by - * *sym1 and *sym2, or NULL if those symbols can't be found. - * - * Side effects: - * New code suddenly appears in memory. - * - *---------------------------------------------------------------------- - */ - -int -TclpLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr, clientDataPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - char *fileName; /* Name of the file containing the desired - * code. */ - char *sym1, *sym2; /* Names of two procedures to look up in - * the file's symbol table. */ - Tcl_PackageInitProc **proc1Ptr, **proc2Ptr; - /* Where to return the addresses corresponding - * to sym1 and sym2. */ - ClientData *clientDataPtr; /* Filled with token for dynamically loaded - * file which will be passed back to - * TclpUnloadFile() to unload the file. */ -{ - static int firstTime = 1; - int returnCode; - - /* - * The dld package needs to know the pathname to the tcl binary. - * If that's not know, return an error. - */ - - if (firstTime) { - if (tclExecutableName == NULL) { - Tcl_SetResult(interp, - "don't know name of application binary file, so can't initialize dynamic loader", - TCL_STATIC); - return TCL_ERROR; - } - returnCode = dld_init(tclExecutableName); - if (returnCode != 0) { - Tcl_AppendResult(interp, - "initialization failed for dynamic loader: ", - dld_strerror(returnCode), (char *) NULL); - return TCL_ERROR; - } - firstTime = 0; - } - - if ((returnCode = dld_link(fileName)) != 0) { - Tcl_AppendResult(interp, "couldn't load file \"", fileName, - "\": ", dld_strerror(returnCode), (char *) NULL); - return TCL_ERROR; - } - *proc1Ptr = (Tcl_PackageInitProc *) dld_get_func(sym1); - *proc2Ptr = (Tcl_PackageInitProc *) dld_get_func(sym2); - *clientDataPtr = strcpy( - (char *) ckalloc((unsigned) (strlen(fileName) + 1)), fileName); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclpUnloadFile -- - * - * Unloads a dynamically loaded binary code file from memory. - * Code pointers in the formerly loaded file are no longer valid - * after calling this function. - * - * Results: - * None. - * - * Side effects: - * Code removed from memory. - * - *---------------------------------------------------------------------- - */ - -void -TclpUnloadFile(clientData) - ClientData clientData; /* ClientData returned by a previous call - * to TclpLoadFile(). The clientData is - * a token that represents the loaded - * file. */ -{ - char *fileName; - - handle = (char *) clientData; - dld_unlink_by_file(handle, 0); - ckfree(handle); -} - -/* - *---------------------------------------------------------------------- - * - * TclGuessPackageName -- - * - * If the "load" command is invoked without providing a package - * name, this procedure is invoked to try to figure it out. - * - * Results: - * Always returns 0 to indicate that we couldn't figure out a - * package name; generic code will then try to guess the package - * from the file name. A return value of 1 would have meant that - * we figured out the package name and put it in bufPtr. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -TclGuessPackageName(fileName, bufPtr) - char *fileName; /* Name of file containing package (already - * translated to local form if needed). */ - Tcl_DString *bufPtr; /* Initialized empty dstring. Append - * package name to this if possible. */ -{ - return 0; -} diff --git a/unix/tclLoadDyld.c b/unix/tclLoadDyld.c deleted file mode 100644 index 9acaaa5..0000000 --- a/unix/tclLoadDyld.c +++ /dev/null @@ -1,171 +0,0 @@ -/* - * tclLoadDyld.c -- - * - * This procedure provides a version of the TclLoadFile that - * works with NeXT/Apple's dyld dynamic loading. This file - * provided by Wilfredo Sanchez (wsanchez@apple.com). - * The works on Mac OS X and Mac OS X Server. - * It should work with OpenStep, but it's not been tried. - * - * Copyright (c) 1995 Apple Computer, Inc. - * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclLoadDyld.c,v 1.2 2000/04/25 17:55:45 hobbs Exp $ - */ - -#include "tclInt.h" -#include <mach-o/dyld.h> - -/* - *---------------------------------------------------------------------- - * - * TclpLoadFile -- - * - * Dynamically loads a binary code file into memory and returns - * the addresses of two procedures within that file, if they - * are defined. - * - * Results: - * A standard Tcl completion code. If an error occurs, an error - * message is left in the interpreter's result. *proc1Ptr and *proc2Ptr - * are filled in with the addresses of the symbols given by - * *sym1 and *sym2, or NULL if those symbols can't be found. - * - * Side effects: - * New code suddenly appears in memory. - * - *---------------------------------------------------------------------- - */ - -int -TclpLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr, clientDataPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - char *fileName; /* Name of the file containing the desired - * code. */ - char *sym1, *sym2; /* Names of two procedures to look up in - * the file's symbol table. */ - Tcl_PackageInitProc **proc1Ptr, **proc2Ptr; - /* Where to return the addresses corresponding - * to sym1 and sym2. */ - ClientData *clientDataPtr; /* Filled with token for dynamically loaded - * file which will be passed back to - * TclpUnloadFile() to unload the file. */ -{ - NSObjectFileImageReturnCode err; - NSObjectFileImage image; - NSModule module; - NSSymbol symbol; - char *name; - - err = NSCreateObjectFileImageFromFile(fileName, &image); - if (err != NSObjectFileImageSuccess) { - switch (err) { - case NSObjectFileImageFailure: - Tcl_SetResult(interp, "dyld: general failure", TCL_STATIC); - break; - case NSObjectFileImageInappropriateFile: - Tcl_SetResult(interp, "dyld: inappropriate Mach-O file", - TCL_STATIC); - break; - case NSObjectFileImageArch: - Tcl_SetResult(interp, - "dyld: inappropriate Mach-O architecture", TCL_STATIC); - break; - case NSObjectFileImageFormat: - Tcl_SetResult(interp, "dyld: invalid Mach-O file format", - TCL_STATIC); - break; - case NSObjectFileImageAccess: - Tcl_SetResult(interp, "dyld: permission denied", TCL_STATIC); - break; - default: - Tcl_SetResult(interp, "dyld: unknown failure", TCL_STATIC); - break; - } - return TCL_ERROR; - } - - module = NSLinkModule(image, fileName, TRUE); - - if (module == NULL) { - Tcl_SetResult(interp, "dyld: falied to link module", TCL_STATIC); - return TCL_ERROR; - } - - name = (char*)malloc(sizeof(char)*(strlen(sym1)+2)); - sprintf(name, "_%s", sym1); - symbol = NSLookupAndBindSymbol(name); - free(name); - *proc1Ptr = NSAddressOfSymbol(symbol); - - name = (char*)malloc(sizeof(char)*(strlen(sym2)+2)); - sprintf(name, "_%s", sym2); - symbol = NSLookupAndBindSymbol(name); - free(name); - *proc2Ptr = NSAddressOfSymbol(symbol); - - *clientDataPtr = module; - - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclpUnloadFile -- - * - * Unloads a dynamically loaded binary code file from memory. - * Code pointers in the formerly loaded file are no longer valid - * after calling this function. - * - * Results: - * None. - * - * Side effects: - * Code dissapears from memory. - * Note that this is a no-op on older (OpenStep) versions of dyld. - * - *---------------------------------------------------------------------- - */ - -void -TclpUnloadFile(clientData) - ClientData clientData; /* ClientData returned by a previous call - * to TclpLoadFile(). The clientData is - * a token that represents the loaded - * file. */ -{ - NSUnLinkModule(clientData, FALSE); -} - -/* - *---------------------------------------------------------------------- - * - * TclGuessPackageName -- - * - * If the "load" command is invoked without providing a package - * name, this procedure is invoked to try to figure it out. - * - * Results: - * Always returns 0 to indicate that we couldn't figure out a - * package name; generic code will then try to guess the package - * from the file name. A return value of 1 would have meant that - * we figured out the package name and put it in bufPtr. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -TclGuessPackageName(fileName, bufPtr) - char *fileName; /* Name of file containing package (already - * translated to local form if needed). */ - Tcl_DString *bufPtr; /* Initialized empty dstring. Append - * package name to this if possible. */ -{ - return 0; -} diff --git a/unix/tclLoadNext.c b/unix/tclLoadNext.c deleted file mode 100644 index f29c996..0000000 --- a/unix/tclLoadNext.c +++ /dev/null @@ -1,142 +0,0 @@ -/* - * tclLoadNext.c -- - * - * This procedure provides a version of the TclLoadFile that - * works with NeXTs rld_* dynamic loading. This file provided - * by Pedja Bogdanovich. - * - * Copyright (c) 1995-1997 Sun Microsystems, Inc. - * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclLoadNext.c,v 1.3 1999/04/16 00:48:04 stanton Exp $ - */ - -#include "tclInt.h" -#include <mach-o/rld.h> -#include <streams/streams.h> - -/* - *---------------------------------------------------------------------- - * - * TclpLoadFile -- - * - * Dynamically loads a binary code file into memory and returns - * the addresses of two procedures within that file, if they - * are defined. - * - * Results: - * A standard Tcl completion code. If an error occurs, an error - * message is left in the interp's result. *proc1Ptr and *proc2Ptr - * are filled in with the addresses of the symbols given by - * *sym1 and *sym2, or NULL if those symbols can't be found. - * - * Side effects: - * New code suddenly appears in memory. - * - *---------------------------------------------------------------------- - */ - -int -TclpLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr, clientDataPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - char *fileName; /* Name of the file containing the desired - * code. */ - char *sym1, *sym2; /* Names of two procedures to look up in - * the file's symbol table. */ - Tcl_PackageInitProc **proc1Ptr, **proc2Ptr; - /* Where to return the addresses corresponding - * to sym1 and sym2. */ - ClientData *clientDataPtr; /* Filled with token for dynamically loaded - * file which will be passed back to - * TclpUnloadFile() to unload the file. */ -{ - struct mach_header *header; - char *data; - int len, maxlen; - char *files[]={fileName,NULL}; - NXStream *errorStream=NXOpenMemory(0,0,NX_READWRITE); - - if(!rld_load(errorStream,&header,files,NULL)) { - NXGetMemoryBuffer(errorStream,&data,&len,&maxlen); - Tcl_AppendResult(interp,"couldn't load file \"",fileName,"\": ",data,NULL); - NXCloseMemory(errorStream,NX_FREEBUFFER); - return TCL_ERROR; - } - NXCloseMemory(errorStream,NX_FREEBUFFER); - - *proc1Ptr=NULL; - if(sym1) { - char sym[strlen(sym1)+2]; - sym[0]='_'; sym[1]=0; strcat(sym,sym1); - rld_lookup(NULL,sym,(unsigned long *)proc1Ptr); - } - - *proc2Ptr=NULL; - if(sym2) { - char sym[strlen(sym2)+2]; - sym[0]='_'; sym[1]=0; strcat(sym,sym2); - rld_lookup(NULL,sym,(unsigned long *)proc2Ptr); - } - *clientDataPtr = NULL; - - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclpUnloadFile -- - * - * Unloads a dynamically loaded binary code file from memory. - * Code pointers in the formerly loaded file are no longer valid - * after calling this function. - * - * Results: - * None. - * - * Side effects: - * Does nothing. Can anything be done? - * - *---------------------------------------------------------------------- - */ - -void -TclpUnloadFile(clientData) - ClientData clientData; /* ClientData returned by a previous call - * to TclpLoadFile(). The clientData is - * a token that represents the loaded - * file. */ -{ -} - -/* - *---------------------------------------------------------------------- - * - * TclGuessPackageName -- - * - * If the "load" command is invoked without providing a package - * name, this procedure is invoked to try to figure it out. - * - * Results: - * Always returns 0 to indicate that we couldn't figure out a - * package name; generic code will then try to guess the package - * from the file name. A return value of 1 would have meant that - * we figured out the package name and put it in bufPtr. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -TclGuessPackageName(fileName, bufPtr) - char *fileName; /* Name of file containing package (already - * translated to local form if needed). */ - Tcl_DString *bufPtr; /* Initialized empty dstring. Append - * package name to this if possible. */ -{ - return 0; -} diff --git a/unix/tclLoadOSF.c b/unix/tclLoadOSF.c deleted file mode 100644 index 9e8b3ad..0000000 --- a/unix/tclLoadOSF.c +++ /dev/null @@ -1,160 +0,0 @@ -/* - * tclLoadOSF.c -- - * - * This procedure provides a version of the TclLoadFile that works - * under OSF/1 1.0/1.1/1.2 and related systems, utilizing the old OSF/1 - * /sbin/loader and /usr/include/loader.h. OSF/1 versions from 1.3 and - * on use ELF, rtld, and dlopen()[/usr/include/ldfcn.h]. - * - * This is useful for: - * OSF/1 1.0, 1.1, 1.2 (from OSF) - * includes: MK4 and AD1 (from OSF RI) - * OSF/1 1.3 (from OSF) using ROSE - * HP OSF/1 1.0 ("Acorn") using COFF - * - * This is likely to be useful for: - * Paragon OSF/1 (from Intel) - * HI-OSF/1 (from Hitachi) - * - * This is NOT to be used on: - * Digitial Alpha OSF/1 systems - * OSF/1 1.3 or later (from OSF) using ELF - * includes: MK6, MK7, AD2, AD3 (from OSF RI) - * - * This approach to things was utter @&^#; thankfully, - * OSF/1 eventually supported dlopen(). - * - * John Robert LoVerso <loverso@freebsd.osf.org> - * - * Copyright (c) 1995-1997 Sun Microsystems, Inc. - * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclLoadOSF.c,v 1.3 1999/04/16 00:48:04 stanton Exp $ - */ - -#include "tclInt.h" -#include <sys/types.h> -#include <loader.h> - -/* - *---------------------------------------------------------------------- - * - * TclpLoadFile -- - * - * Dynamically loads a binary code file into memory and returns - * the addresses of two procedures within that file, if they - * are defined. - * - * Results: - * A standard Tcl completion code. If an error occurs, an error - * message is left in the interp's result. *proc1Ptr and *proc2Ptr - * are filled in with the addresses of the symbols given by - * *sym1 and *sym2, or NULL if those symbols can't be found. - * - * Side effects: - * New code suddenly appears in memory. - * - *---------------------------------------------------------------------- - */ - -int -TclpLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr, clientDataPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - char *fileName; /* Name of the file containing the desired - * code. */ - char *sym1, *sym2; /* Names of two procedures to look up in - * the file's symbol table. */ - Tcl_PackageInitProc **proc1Ptr, **proc2Ptr; - /* Where to return the addresses corresponding - * to sym1 and sym2. */ - ClientData *clientDataPtr; /* Filled with token for dynamically loaded - * file which will be passed back to - * TclpUnloadFile() to unload the file. */ -{ - ldr_module_t lm; - char *pkg; - - lm = (Tcl_PackageInitProc *) load(fileName, LDR_NOFLAGS); - if (lm == LDR_NULL_MODULE) { - Tcl_AppendResult(interp, "couldn't load file \"", fileName, - "\": ", Tcl_PosixError (interp), (char *) NULL); - return TCL_ERROR; - } - - *clientDataPtr = NULL; - - /* - * My convention is to use a [OSF loader] package name the same as shlib, - * since the idiots never implemented ldr_lookup() and it is otherwise - * impossible to get a package name given a module. - * - * I build loadable modules with a makefile rule like - * ld ... -export $@: -o $@ $(OBJS) - */ - if ((pkg = strrchr(fileName, '/')) == NULL) - pkg = fileName; - else - pkg++; - *proc1Ptr = ldr_lookup_package(pkg, sym1); - *proc2Ptr = ldr_lookup_package(pkg, sym2); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclpUnloadFile -- - * - * Unloads a dynamically loaded binary code file from memory. - * Code pointers in the formerly loaded file are no longer valid - * after calling this function. - * - * Results: - * None. - * - * Side effects: - * Does nothing. Can anything be done? - * - *---------------------------------------------------------------------- - */ - -void -TclpUnloadFile(clientData) - ClientData clientData; /* ClientData returned by a previous call - * to TclpLoadFile(). The clientData is - * a token that represents the loaded - * file. */ -{ -} - -/* - *---------------------------------------------------------------------- - * - * TclGuessPackageName -- - * - * If the "load" command is invoked without providing a package - * name, this procedure is invoked to try to figure it out. - * - * Results: - * Always returns 0 to indicate that we couldn't figure out a - * package name; generic code will then try to guess the package - * from the file name. A return value of 1 would have meant that - * we figured out the package name and put it in bufPtr. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -TclGuessPackageName(fileName, bufPtr) - char *fileName; /* Name of file containing package (already - * translated to local form if needed). */ - Tcl_DString *bufPtr; /* Initialized empty dstring. Append - * package name to this if possible. */ -{ - return 0; -} diff --git a/unix/tclLoadShl.c b/unix/tclLoadShl.c deleted file mode 100644 index 3330919..0000000 --- a/unix/tclLoadShl.c +++ /dev/null @@ -1,174 +0,0 @@ -/* - * tclLoadShl.c -- - * - * This procedure provides a version of the TclLoadFile that works - * with the "shl_load" and "shl_findsym" library procedures for - * dynamic loading (e.g. for HP machines). - * - * Copyright (c) 1995-1997 Sun Microsystems, Inc. - * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclLoadShl.c,v 1.3 1999/04/16 00:48:04 stanton Exp $ - */ - -#include <dl.h> - -/* - * On some HP machines, dl.h defines EXTERN; remove that definition. - */ - -#ifdef EXTERN -# undef EXTERN -#endif - -#include "tcl.h" - -/* - *---------------------------------------------------------------------- - * - * TclpLoadFile -- - * - * Dynamically loads a binary code file into memory and returns - * the addresses of two procedures within that file, if they - * are defined. - * - * Results: - * A standard Tcl completion code. If an error occurs, an error - * message is left in the interp's result. *proc1Ptr and *proc2Ptr - * are filled in with the addresses of the symbols given by - * *sym1 and *sym2, or NULL if those symbols can't be found. - * - * Side effects: - * New code suddenly appears in memory. - * - *---------------------------------------------------------------------- - */ - -int -TclpLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr, clientDataPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - char *fileName; /* Name of the file containing the desired - * code. */ - char *sym1, *sym2; /* Names of two procedures to look up in - * the file's symbol table. */ - Tcl_PackageInitProc **proc1Ptr, **proc2Ptr; - /* Where to return the addresses corresponding - * to sym1 and sym2. */ - ClientData *clientDataPtr; /* Filled with token for dynamically loaded - * file which will be passed back to - * TclpUnloadFile() to unload the file. */ -{ - shl_t handle; - Tcl_DString newName; - - /* - * The flags below used to be BIND_IMMEDIATE; they were changed at - * the suggestion of Wolfgang Kechel (wolfgang@prs.de): "This - * enables verbosity for missing symbols when loading a shared lib - * and allows to load libtk8.0.sl into tclsh8.0 without problems. - * In general, this delays resolving symbols until they are actually - * needed. Shared libs do no longer need all libraries linked in - * when they are build." - */ - - handle = shl_load(fileName, BIND_DEFERRED|BIND_VERBOSE, 0L); - if (handle == NULL) { - Tcl_AppendResult(interp, "couldn't load file \"", fileName, - "\": ", Tcl_PosixError(interp), (char *) NULL); - return TCL_ERROR; - } - *clientDataPtr = (ClientData) handle; - - /* - * Some versions of the HP system software still use "_" at the - * beginning of exported symbols while others don't; try both - * forms of each name. - */ - - if (shl_findsym(&handle, sym1, (short) TYPE_PROCEDURE, (void *) proc1Ptr) - != 0) { - Tcl_DStringInit(&newName); - Tcl_DStringAppend(&newName, "_", 1); - Tcl_DStringAppend(&newName, sym1, -1); - if (shl_findsym(&handle, Tcl_DStringValue(&newName), - (short) TYPE_PROCEDURE, (void *) proc1Ptr) != 0) { - *proc1Ptr = NULL; - } - Tcl_DStringFree(&newName); - } - if (shl_findsym(&handle, sym2, (short) TYPE_PROCEDURE, (void *) proc2Ptr) - != 0) { - Tcl_DStringInit(&newName); - Tcl_DStringAppend(&newName, "_", 1); - Tcl_DStringAppend(&newName, sym2, -1); - if (shl_findsym(&handle, Tcl_DStringValue(&newName), - (short) TYPE_PROCEDURE, (void *) proc2Ptr) != 0) { - *proc2Ptr = NULL; - } - Tcl_DStringFree(&newName); - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclpUnloadFile -- - * - * Unloads a dynamically loaded binary code file from memory. - * Code pointers in the formerly loaded file are no longer valid - * after calling this function. - * - * Results: - * None. - * - * Side effects: - * Code removed from memory. - * - *---------------------------------------------------------------------- - */ - -void -TclpUnloadFile(clientData) - ClientData clientData; /* ClientData returned by a previous call - * to TclpLoadFile(). The clientData is - * a token that represents the loaded - * file. */ -{ - shl_t handle; - - handle = (shl_t) clientData; - shl_unload(handle); -} - -/* - *---------------------------------------------------------------------- - * - * TclGuessPackageName -- - * - * If the "load" command is invoked without providing a package - * name, this procedure is invoked to try to figure it out. - * - * Results: - * Always returns 0 to indicate that we couldn't figure out a - * package name; generic code will then try to guess the package - * from the file name. A return value of 1 would have meant that - * we figured out the package name and put it in bufPtr. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -TclGuessPackageName(fileName, bufPtr) - char *fileName; /* Name of file containing package (already - * translated to local form if needed). */ - Tcl_DString *bufPtr; /* Initialized empty dstring. Append - * package name to this if possible. */ -{ - return 0; -} diff --git a/unix/tclMtherr.c b/unix/tclMtherr.c deleted file mode 100644 index d1150f6..0000000 --- a/unix/tclMtherr.c +++ /dev/null @@ -1,77 +0,0 @@ -/* - * tclMatherr.c -- - * - * This function provides a default implementation of the - * "matherr" function, for SYS-V systems where it's needed. - * - * Copyright (c) 1993-1994 The Regents of the University of California. - * Copyright (c) 1994 Sun Microsystems, Inc. - * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclMtherr.c,v 1.3 1999/04/16 00:48:04 stanton Exp $ - */ - -#include "tclInt.h" -#include <math.h> - -#ifndef TCL_GENERIC_ONLY -#include "tclPort.h" -#else -#define NO_ERRNO_H -#endif - -#ifdef NO_ERRNO_H -extern int errno; /* Use errno from tclExecute.c. */ -#define EDOM 33 -#define ERANGE 34 -#endif - -/* - * The following definitions allow matherr to compile on systems - * that don't really support it. The compiled procedure is bogus, - * but it will never be executed on these systems anyway. - */ - -#ifndef NEED_MATHERR -struct exception { - int type; -}; -#define DOMAIN 0 -#define SING 0 -#endif - -/* - *---------------------------------------------------------------------- - * - * matherr -- - * - * This procedure is invoked on Sys-V systems when certain - * errors occur in mathematical functions. Type "man matherr" - * for more information on how this function works. - * - * Results: - * Returns 1 to indicate that we've handled the error - * locally. - * - * Side effects: - * Sets errno based on what's in xPtr. - * - *---------------------------------------------------------------------- - */ - -int -matherr(xPtr) - struct exception *xPtr; /* Describes error that occurred. */ -{ - if (TclMathInProgress()) { - return 0; - } - if ((xPtr->type == DOMAIN) || (xPtr->type == SING)) { - errno = EDOM; - } else { - errno = ERANGE; - } - return 1; -} diff --git a/unix/tclUnixChan.c b/unix/tclUnixChan.c deleted file mode 100644 index 1bf4818..0000000 --- a/unix/tclUnixChan.c +++ /dev/null @@ -1,2735 +0,0 @@ -/* - * tclUnixChan.c - * - * Common channel driver for Unix channels based on files, command - * pipes and TCP sockets. - * - * Copyright (c) 1995-1997 Sun Microsystems, Inc. - * Copyright (c) 1998-1999 by Scriptics Corporation. - * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclUnixChan.c,v 1.17 2000/04/19 09:17:03 hobbs Exp $ - */ - -#include "tclInt.h" /* Internal definitions for Tcl. */ -#include "tclPort.h" /* Portability features for Tcl. */ - -/* - * sys/ioctl.h has already been included by tclPort.h. Including termios.h - * or termio.h causes a bunch of warning messages because some duplicate - * (but not contradictory) #defines exist in termios.h and/or termio.h - */ -#undef NL0 -#undef NL1 -#undef CR0 -#undef CR1 -#undef CR2 -#undef CR3 -#undef TAB0 -#undef TAB1 -#undef TAB2 -#undef XTABS -#undef BS0 -#undef BS1 -#undef FF0 -#undef FF1 -#undef ECHO -#undef NOFLSH -#undef TOSTOP -#undef FLUSHO -#undef PENDIN - -#define SUPPORTS_TTY - -#ifdef USE_TERMIOS -# include <termios.h> -# define IOSTATE struct termios -# define GETIOSTATE(fd, statePtr) tcgetattr((fd), (statePtr)) -# define SETIOSTATE(fd, statePtr) tcsetattr((fd), TCSADRAIN, (statePtr)) -#else /* !USE_TERMIOS */ -#ifdef USE_TERMIO -# include <termio.h> -# define IOSTATE struct termio -# define GETIOSTATE(fd, statePtr) ioctl((fd), TCGETA, (statePtr)) -# define SETIOSTATE(fd, statePtr) ioctl((fd), TCSETAW, (statePtr)) -#else /* !USE_TERMIO */ -#ifdef USE_SGTTY -# include <sgtty.h> -# define IOSTATE struct sgttyb -# define GETIOSTATE(fd, statePtr) ioctl((fd), TIOCGETP, (statePtr)) -# define SETIOSTATE(fd, statePtr) ioctl((fd), TIOCSETP, (statePtr)) -#else /* !USE_SGTTY */ -# undef SUPPORTS_TTY -#endif /* !USE_SGTTY */ -#endif /* !USE_TERMIO */ -#endif /* !USE_TERMIOS */ - -/* - * This structure describes per-instance state of a file based channel. - */ - -typedef struct FileState { - Tcl_Channel channel; /* Channel associated with this file. */ - int fd; /* File handle. */ - int validMask; /* OR'ed combination of TCL_READABLE, - * TCL_WRITABLE, or TCL_EXCEPTION: indicates - * which operations are valid on the file. */ - struct FileState *nextPtr; /* Pointer to next file in list of all - * file channels. */ -} FileState; - -#ifdef SUPPORTS_TTY - -/* - * The following structure describes per-instance state of a tty-based - * channel. - */ - -typedef struct TtyState { - FileState fs; /* Per-instance state of the file - * descriptor. Must be the first field. */ - IOSTATE savedState; /* Initial state of device. Used to reset - * state when device closed. */ -} TtyState; - -/* - * The following structure is used to set or get the serial port - * attributes in a platform-independant manner. - */ - -typedef struct TtyAttrs { - int baud; - int parity; - int data; - int stop; -} TtyAttrs; - -#endif /* !SUPPORTS_TTY */ - -typedef struct ThreadSpecificData { - /* - * List of all file channels currently open. This is per thread and is - * used to match up fd's to channels, which rarely occurs. - */ - - FileState *firstFilePtr; -} ThreadSpecificData; - -static Tcl_ThreadDataKey dataKey; - -/* - * This structure describes per-instance state of a tcp based channel. - */ - -typedef struct TcpState { - Tcl_Channel channel; /* Channel associated with this file. */ - int fd; /* The socket itself. */ - int flags; /* ORed combination of the bitfields - * defined below. */ - Tcl_TcpAcceptProc *acceptProc; - /* Proc to call on accept. */ - ClientData acceptProcData; /* The data for the accept proc. */ -} TcpState; - -/* - * These bits may be ORed together into the "flags" field of a TcpState - * structure. - */ - -#define TCP_ASYNC_SOCKET (1<<0) /* Asynchronous socket. */ -#define TCP_ASYNC_CONNECT (1<<1) /* Async connect in progress. */ - -/* - * The following defines the maximum length of the listen queue. This is - * the number of outstanding yet-to-be-serviced requests for a connection - * on a server socket, more than this number of outstanding requests and - * the connection request will fail. - */ - -#ifndef SOMAXCONN -#define SOMAXCONN 100 -#endif - -#if (SOMAXCONN < 100) -#undef SOMAXCONN -#define SOMAXCONN 100 -#endif - -/* - * The following defines how much buffer space the kernel should maintain - * for a socket. - */ - -#define SOCKET_BUFSIZE 4096 - -/* - * Static routines for this file: - */ - -static TcpState * CreateSocket _ANSI_ARGS_((Tcl_Interp *interp, - int port, char *host, int server, - char *myaddr, int myport, int async)); -static int CreateSocketAddress _ANSI_ARGS_( - (struct sockaddr_in *sockaddrPtr, - char *host, int port)); -static int FileBlockModeProc _ANSI_ARGS_(( - ClientData instanceData, int mode)); -static int FileCloseProc _ANSI_ARGS_((ClientData instanceData, - Tcl_Interp *interp)); -static int FileGetHandleProc _ANSI_ARGS_((ClientData instanceData, - int direction, ClientData *handlePtr)); -static int FileInputProc _ANSI_ARGS_((ClientData instanceData, - char *buf, int toRead, int *errorCode)); -static int FileOutputProc _ANSI_ARGS_(( - ClientData instanceData, char *buf, int toWrite, - int *errorCode)); -static int FileSeekProc _ANSI_ARGS_((ClientData instanceData, - long offset, int mode, int *errorCode)); -static void FileWatchProc _ANSI_ARGS_((ClientData instanceData, - int mask)); -static void TcpAccept _ANSI_ARGS_((ClientData data, int mask)); -static int TcpBlockModeProc _ANSI_ARGS_((ClientData data, - int mode)); -static int TcpCloseProc _ANSI_ARGS_((ClientData instanceData, - Tcl_Interp *interp)); -static int TcpGetHandleProc _ANSI_ARGS_((ClientData instanceData, - int direction, ClientData *handlePtr)); -static int TcpGetOptionProc _ANSI_ARGS_((ClientData instanceData, - Tcl_Interp *interp, char *optionName, - Tcl_DString *dsPtr)); -static int TcpInputProc _ANSI_ARGS_((ClientData instanceData, - char *buf, int toRead, int *errorCode)); -static int TcpOutputProc _ANSI_ARGS_((ClientData instanceData, - char *buf, int toWrite, int *errorCode)); -static void TcpWatchProc _ANSI_ARGS_((ClientData instanceData, - int mask)); -#ifdef SUPPORTS_TTY -static int TtyCloseProc _ANSI_ARGS_((ClientData instanceData, - Tcl_Interp *interp)); -static void TtyGetAttributes _ANSI_ARGS_((int fd, - TtyAttrs *ttyPtr)); -static int TtyGetOptionProc _ANSI_ARGS_((ClientData instanceData, - Tcl_Interp *interp, char *optionName, - Tcl_DString *dsPtr)); -static FileState * TtyInit _ANSI_ARGS_((int fd)); -static int TtyParseMode _ANSI_ARGS_((Tcl_Interp *interp, - CONST char *mode, int *speedPtr, int *parityPtr, - int *dataPtr, int *stopPtr)); -static void TtySetAttributes _ANSI_ARGS_((int fd, - TtyAttrs *ttyPtr)); -static int TtySetOptionProc _ANSI_ARGS_((ClientData instanceData, - Tcl_Interp *interp, char *optionName, - char *value)); -#endif /* SUPPORTS_TTY */ -static int WaitForConnect _ANSI_ARGS_((TcpState *statePtr, - int *errorCodePtr)); - -/* - * This structure describes the channel type structure for file based IO: - */ - -static Tcl_ChannelType fileChannelType = { - "file", /* Type name. */ - FileBlockModeProc, /* Set blocking/nonblocking mode.*/ - FileCloseProc, /* Close proc. */ - FileInputProc, /* Input proc. */ - FileOutputProc, /* Output proc. */ - FileSeekProc, /* Seek proc. */ - NULL, /* Set option proc. */ - NULL, /* Get option proc. */ - FileWatchProc, /* Initialize notifier. */ - FileGetHandleProc, /* Get OS handles out of channel. */ -}; - -#ifdef SUPPORTS_TTY -/* - * This structure describes the channel type structure for serial IO. - * Note that this type is a subclass of the "file" type. - */ - -static Tcl_ChannelType ttyChannelType = { - "tty", /* Type name. */ - FileBlockModeProc, /* Set blocking/nonblocking mode.*/ - TtyCloseProc, /* Close proc. */ - FileInputProc, /* Input proc. */ - FileOutputProc, /* Output proc. */ - NULL, /* Seek proc. */ - TtySetOptionProc, /* Set option proc. */ - TtyGetOptionProc, /* Get option proc. */ - FileWatchProc, /* Initialize notifier. */ - FileGetHandleProc, /* Get OS handles out of channel. */ -}; -#endif /* SUPPORTS_TTY */ - -/* - * This structure describes the channel type structure for TCP socket - * based IO: - */ - -static Tcl_ChannelType tcpChannelType = { - "tcp", /* Type name. */ - TcpBlockModeProc, /* Set blocking/nonblocking mode.*/ - TcpCloseProc, /* Close proc. */ - TcpInputProc, /* Input proc. */ - TcpOutputProc, /* Output proc. */ - NULL, /* Seek proc. */ - NULL, /* Set option proc. */ - TcpGetOptionProc, /* Get option proc. */ - TcpWatchProc, /* Initialize notifier. */ - TcpGetHandleProc, /* Get OS handles out of channel. */ -}; - - -/* - *---------------------------------------------------------------------- - * - * FileBlockModeProc -- - * - * Helper procedure to set blocking and nonblocking modes on a - * file based channel. Invoked by generic IO level code. - * - * Results: - * 0 if successful, errno when failed. - * - * Side effects: - * Sets the device into blocking or non-blocking mode. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -static int -FileBlockModeProc(instanceData, mode) - ClientData instanceData; /* File state. */ - int mode; /* The mode to set. Can be one of - * TCL_MODE_BLOCKING or - * TCL_MODE_NONBLOCKING. */ -{ - FileState *fsPtr = (FileState *) instanceData; - int curStatus; - -#ifndef USE_FIONBIO - curStatus = fcntl(fsPtr->fd, F_GETFL); - if (mode == TCL_MODE_BLOCKING) { - curStatus &= (~(O_NONBLOCK)); - } else { - curStatus |= O_NONBLOCK; - } - if (fcntl(fsPtr->fd, F_SETFL, curStatus) < 0) { - return errno; - } - curStatus = fcntl(fsPtr->fd, F_GETFL); -#else - if (mode == TCL_MODE_BLOCKING) { - curStatus = 0; - } else { - curStatus = 1; - } - if (ioctl(fsPtr->fd, (int) FIONBIO, &curStatus) < 0) { - return errno; - } -#endif - return 0; -} - -/* - *---------------------------------------------------------------------- - * - * FileInputProc -- - * - * This procedure is invoked from the generic IO level to read - * input from a file based channel. - * - * Results: - * The number of bytes read is returned or -1 on error. An output - * argument contains a POSIX error code if an error occurs, or zero. - * - * Side effects: - * Reads input from the input device of the channel. - * - *---------------------------------------------------------------------- - */ - -static int -FileInputProc(instanceData, buf, toRead, errorCodePtr) - ClientData instanceData; /* File state. */ - char *buf; /* Where to store data read. */ - int toRead; /* How much space is available - * in the buffer? */ - int *errorCodePtr; /* Where to store error code. */ -{ - FileState *fsPtr = (FileState *) instanceData; - int bytesRead; /* How many bytes were actually - * read from the input device? */ - - *errorCodePtr = 0; - - /* - * Assume there is always enough input available. This will block - * appropriately, and read will unblock as soon as a short read is - * possible, if the channel is in blocking mode. If the channel is - * nonblocking, the read will never block. - */ - - bytesRead = read(fsPtr->fd, buf, (size_t) toRead); - if (bytesRead > -1) { - return bytesRead; - } - *errorCodePtr = errno; - return -1; -} - -/* - *---------------------------------------------------------------------- - * - * FileOutputProc-- - * - * This procedure is invoked from the generic IO level to write - * output to a file channel. - * - * Results: - * The number of bytes written is returned or -1 on error. An - * output argument contains a POSIX error code if an error occurred, - * or zero. - * - * Side effects: - * Writes output on the output device of the channel. - * - *---------------------------------------------------------------------- - */ - -static int -FileOutputProc(instanceData, buf, toWrite, errorCodePtr) - ClientData instanceData; /* File state. */ - char *buf; /* The data buffer. */ - int toWrite; /* How many bytes to write? */ - int *errorCodePtr; /* Where to store error code. */ -{ - FileState *fsPtr = (FileState *) instanceData; - int written; - - *errorCodePtr = 0; - written = write(fsPtr->fd, buf, (size_t) toWrite); - if (written > -1) { - return written; - } - *errorCodePtr = errno; - return -1; -} - -/* - *---------------------------------------------------------------------- - * - * FileCloseProc -- - * - * This procedure is called from the generic IO level to perform - * channel-type-specific cleanup when a file based channel is closed. - * - * Results: - * 0 if successful, errno if failed. - * - * Side effects: - * Closes the device of the channel. - * - *---------------------------------------------------------------------- - */ - -static int -FileCloseProc(instanceData, interp) - ClientData instanceData; /* File state. */ - Tcl_Interp *interp; /* For error reporting - unused. */ -{ - FileState *fsPtr = (FileState *) instanceData; - FileState **nextPtrPtr; - int errorCode = 0; - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - - Tcl_DeleteFileHandler(fsPtr->fd); - - /* - * Do not close standard channels while in thread-exit. - */ - - if (!TclInExit() - || ((fsPtr->fd != 0) && (fsPtr->fd != 1) && (fsPtr->fd != 2))) { - if (close(fsPtr->fd) < 0) { - errorCode = errno; - } - } - for (nextPtrPtr = &(tsdPtr->firstFilePtr); (*nextPtrPtr) != NULL; - nextPtrPtr = &((*nextPtrPtr)->nextPtr)) { - if ((*nextPtrPtr) == fsPtr) { - (*nextPtrPtr) = fsPtr->nextPtr; - break; - } - } - ckfree((char *) fsPtr); - return errorCode; -} - -/* - *---------------------------------------------------------------------- - * - * FileSeekProc -- - * - * This procedure is called by the generic IO level to move the - * access point in a file based channel. - * - * Results: - * -1 if failed, the new position if successful. An output - * argument contains the POSIX error code if an error occurred, - * or zero. - * - * Side effects: - * Moves the location at which the channel will be accessed in - * future operations. - * - *---------------------------------------------------------------------- - */ - -static int -FileSeekProc(instanceData, offset, mode, errorCodePtr) - ClientData instanceData; /* File state. */ - long offset; /* Offset to seek to. */ - int mode; /* Relative to where - * should we seek? Can be - * one of SEEK_START, - * SEEK_SET or SEEK_END. */ - int *errorCodePtr; /* To store error code. */ -{ - FileState *fsPtr = (FileState *) instanceData; - int newLoc; - - newLoc = lseek(fsPtr->fd, (off_t) offset, mode); - - *errorCodePtr = (newLoc == -1) ? errno : 0; - return newLoc; -} - -/* - *---------------------------------------------------------------------- - * - * FileWatchProc -- - * - * Initialize the notifier to watch the fd from this channel. - * - * Results: - * None. - * - * Side effects: - * Sets up the notifier so that a future event on the channel will - * be seen by Tcl. - * - *---------------------------------------------------------------------- - */ - -static void -FileWatchProc(instanceData, mask) - ClientData instanceData; /* The file state. */ - int mask; /* Events of interest; an OR-ed - * combination of TCL_READABLE, - * TCL_WRITABLE and TCL_EXCEPTION. */ -{ - FileState *fsPtr = (FileState *) instanceData; - - /* - * Make sure we only register for events that are valid on this file. - * Note that we are passing Tcl_NotifyChannel directly to - * Tcl_CreateFileHandler with the channel pointer as the client data. - */ - - mask &= fsPtr->validMask; - if (mask) { - Tcl_CreateFileHandler(fsPtr->fd, mask, - (Tcl_FileProc *) Tcl_NotifyChannel, - (ClientData) fsPtr->channel); - } else { - Tcl_DeleteFileHandler(fsPtr->fd); - } -} - -/* - *---------------------------------------------------------------------- - * - * FileGetHandleProc -- - * - * Called from Tcl_GetChannelHandle to retrieve OS handles from - * a file based channel. - * - * Results: - * Returns TCL_OK with the fd in handlePtr, or TCL_ERROR if - * there is no handle for the specified direction. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -FileGetHandleProc(instanceData, direction, handlePtr) - ClientData instanceData; /* The file state. */ - int direction; /* TCL_READABLE or TCL_WRITABLE */ - ClientData *handlePtr; /* Where to store the handle. */ -{ - FileState *fsPtr = (FileState *) instanceData; - - if (direction & fsPtr->validMask) { - *handlePtr = (ClientData) fsPtr->fd; - return TCL_OK; - } else { - return TCL_ERROR; - } -} - -#ifdef SUPPORTS_TTY - -/* - *---------------------------------------------------------------------- - * - * TtyCloseProc -- - * - * This procedure is called from the generic IO level to perform - * channel-type-specific cleanup when a tty based channel is closed. - * - * Results: - * 0 if successful, errno if failed. - * - * Side effects: - * Restores the settings and closes the device of the channel. - * - *---------------------------------------------------------------------- - */ - -static int -TtyCloseProc(instanceData, interp) - ClientData instanceData; /* Tty state. */ - Tcl_Interp *interp; /* For error reporting - unused. */ -{ - TtyState *ttyPtr; - - ttyPtr = (TtyState *) instanceData; - SETIOSTATE(ttyPtr->fs.fd, &ttyPtr->savedState); - return FileCloseProc(instanceData, interp); -} - -/* - *---------------------------------------------------------------------- - * - * TtySetOptionProc -- - * - * Sets an option on a channel. - * - * Results: - * A standard Tcl result. Also sets the interp's result on error if - * interp is not NULL. - * - * Side effects: - * May modify an option on a device. - * Sets Error message if needed (by calling Tcl_BadChannelOption). - * - *---------------------------------------------------------------------- - */ - -static int -TtySetOptionProc(instanceData, interp, optionName, value) - ClientData instanceData; /* File state. */ - Tcl_Interp *interp; /* For error reporting - can be NULL. */ - char *optionName; /* Which option to set? */ - char *value; /* New value for option. */ -{ - FileState *fsPtr = (FileState *) instanceData; - unsigned int len; - TtyAttrs tty; - - len = strlen(optionName); - if ((len > 1) && (strncmp(optionName, "-mode", len) == 0)) { - if (TtyParseMode(interp, value, &tty.baud, &tty.parity, &tty.data, - &tty.stop) != TCL_OK) { - return TCL_ERROR; - } - /* - * system calls results should be checked there. -- dl - */ - - TtySetAttributes(fsPtr->fd, &tty); - return TCL_OK; - } else { - return Tcl_BadChannelOption(interp, optionName, "mode"); - } -} - -/* - *---------------------------------------------------------------------- - * - * TtyGetOptionProc -- - * - * Gets a mode associated with an IO channel. If the optionName arg - * is non NULL, retrieves the value of that option. If the optionName - * arg is NULL, retrieves a list of alternating option names and - * values for the given channel. - * - * Results: - * A standard Tcl result. Also sets the supplied DString to the - * string value of the option(s) returned. - * - * Side effects: - * The string returned by this function is in static storage and - * may be reused at any time subsequent to the call. - * Sets Error message if needed (by calling Tcl_BadChannelOption). - * - *---------------------------------------------------------------------- - */ - -static int -TtyGetOptionProc(instanceData, interp, optionName, dsPtr) - ClientData instanceData; /* File state. */ - Tcl_Interp *interp; /* For error reporting - can be NULL. */ - char *optionName; /* Option to get. */ - Tcl_DString *dsPtr; /* Where to store value(s). */ -{ - FileState *fsPtr = (FileState *) instanceData; - unsigned int len; - char buf[3 * TCL_INTEGER_SPACE + 16]; - TtyAttrs tty; - - if (optionName == NULL) { - Tcl_DStringAppendElement(dsPtr, "-mode"); - len = 0; - } else { - len = strlen(optionName); - } - if ((len == 0) || - ((len > 1) && (strncmp(optionName, "-mode", len) == 0))) { - TtyGetAttributes(fsPtr->fd, &tty); - sprintf(buf, "%d,%c,%d,%d", tty.baud, tty.parity, tty.data, tty.stop); - Tcl_DStringAppendElement(dsPtr, buf); - return TCL_OK; - } else { - return Tcl_BadChannelOption(interp, optionName, "mode"); - } -} - -#undef DIRECT_BAUD -#ifdef B4800 -# if (B4800 == 4800) -# define DIRECT_BAUD -# endif -#endif - -#ifdef DIRECT_BAUD -# define TtyGetSpeed(baud) ((unsigned) (baud)) -# define TtyGetBaud(speed) ((int) (speed)) -#else - -static struct {int baud; unsigned long speed;} speeds[] = { -#ifdef B0 - {0, B0}, -#endif -#ifdef B50 - {50, B50}, -#endif -#ifdef B75 - {75, B75}, -#endif -#ifdef B110 - {110, B110}, -#endif -#ifdef B134 - {134, B134}, -#endif -#ifdef B150 - {150, B150}, -#endif -#ifdef B200 - {200, B200}, -#endif -#ifdef B300 - {300, B300}, -#endif -#ifdef B600 - {600, B600}, -#endif -#ifdef B1200 - {1200, B1200}, -#endif -#ifdef B1800 - {1800, B1800}, -#endif -#ifdef B2400 - {2400, B2400}, -#endif -#ifdef B4800 - {4800, B4800}, -#endif -#ifdef B9600 - {9600, B9600}, -#endif -#ifdef B14400 - {14400, B14400}, -#endif -#ifdef B19200 - {19200, B19200}, -#endif -#ifdef EXTA - {19200, EXTA}, -#endif -#ifdef B28800 - {28800, B28800}, -#endif -#ifdef B38400 - {38400, B38400}, -#endif -#ifdef EXTB - {38400, EXTB}, -#endif -#ifdef B57600 - {57600, B57600}, -#endif -#ifdef _B57600 - {57600, _B57600}, -#endif -#ifdef B76800 - {76800, B76800}, -#endif -#ifdef B115200 - {115200, B115200}, -#endif -#ifdef _B115200 - {115200, _B115200}, -#endif -#ifdef B153600 - {153600, B153600}, -#endif -#ifdef B230400 - {230400, B230400}, -#endif -#ifdef B307200 - {307200, B307200}, -#endif -#ifdef B460800 - {460800, B460800}, -#endif - {-1, 0} -}; - -/* - *--------------------------------------------------------------------------- - * - * TtyGetSpeed -- - * - * Given a baud rate, get the mask value that should be stored in - * the termios, termio, or sgttyb structure in order to select that - * baud rate. - * - * Results: - * As above. - * - * Side effects: - * None. - * - *--------------------------------------------------------------------------- - */ - -static unsigned long -TtyGetSpeed(baud) - int baud; /* The baud rate to look up. */ -{ - int bestIdx, bestDiff, i, diff; - - bestIdx = 0; - bestDiff = 1000000; - - /* - * If the baud rate does not correspond to one of the known mask values, - * choose the mask value whose baud rate is closest to the specified - * baud rate. - */ - - for (i = 0; speeds[i].baud >= 0; i++) { - diff = speeds[i].baud - baud; - if (diff < 0) { - diff = -diff; - } - if (diff < bestDiff) { - bestIdx = i; - bestDiff = diff; - } - } - return speeds[bestIdx].speed; -} - -/* - *--------------------------------------------------------------------------- - * - * TtyGetBaud -- - * - * Given a speed mask value from a termios, termio, or sgttyb - * structure, get the baus rate that corresponds to that mask value. - * - * Results: - * As above. If the mask value was not recognized, 0 is returned. - * - * Side effects: - * None. - * - *--------------------------------------------------------------------------- - */ - -static int -TtyGetBaud(speed) - unsigned long speed; /* Speed mask value to look up. */ -{ - int i; - - for (i = 0; speeds[i].baud >= 0; i++) { - if (speeds[i].speed == speed) { - return speeds[i].baud; - } - } - return 0; -} - -#endif /* !DIRECT_BAUD */ - - -/* - *--------------------------------------------------------------------------- - * - * TtyGetAttributes -- - * - * Get the current attributes of the specified serial device. - * - * Results: - * None. - * - * Side effects: - * None. - * - *--------------------------------------------------------------------------- - */ - -static void -TtyGetAttributes(fd, ttyPtr) - int fd; /* Open file descriptor for serial port to - * be queried. */ - TtyAttrs *ttyPtr; /* Buffer filled with serial port - * attributes. */ -{ - IOSTATE iostate; - int baud, parity, data, stop; - - GETIOSTATE(fd, &iostate); - -#ifdef USE_TERMIOS - baud = TtyGetBaud(cfgetospeed(&iostate)); - - parity = 'n'; -#ifdef PAREXT - switch ((int) (iostate.c_cflag & (PARENB | PARODD | PAREXT))) { - case PARENB : parity = 'e'; break; - case PARENB | PARODD : parity = 'o'; break; - case PARENB | PAREXT : parity = 's'; break; - case PARENB | PARODD | PAREXT : parity = 'm'; break; - } -#else /* !PAREXT */ - switch ((int) (iostate.c_cflag & (PARENB | PARODD))) { - case PARENB : parity = 'e'; break; - case PARENB | PARODD : parity = 'o'; break; - } -#endif /* !PAREXT */ - - data = iostate.c_cflag & CSIZE; - data = (data == CS5) ? 5 : (data == CS6) ? 6 : (data == CS7) ? 7 : 8; - - stop = (iostate.c_cflag & CSTOPB) ? 2 : 1; -#endif /* USE_TERMIOS */ - -#ifdef USE_TERMIO - baud = TtyGetBaud(iostate.c_cflag & CBAUD); - - parity = 'n'; - switch (iostate.c_cflag & (PARENB | PARODD | PAREXT)) { - case PARENB : parity = 'e'; break; - case PARENB | PARODD : parity = 'o'; break; - case PARENB | PAREXT : parity = 's'; break; - case PARENB | PARODD | PAREXT : parity = 'm'; break; - } - - data = iostate.c_cflag & CSIZE; - data = (data == CS5) ? 5 : (data == CS6) ? 6 : (data == CS7) ? 7 : 8; - - stop = (iostate.c_cflag & CSTOPB) ? 2 : 1; -#endif /* USE_TERMIO */ - -#ifdef USE_SGTTY - baud = TtyGetBaud(iostate.sg_ospeed); - - parity = 'n'; - if (iostate.sg_flags & EVENP) { - parity = 'e'; - } else if (iostate.sg_flags & ODDP) { - parity = 'o'; - } - - data = (iostate.sg_flags & (EVENP | ODDP)) ? 7 : 8; - - stop = 1; -#endif /* USE_SGTTY */ - - ttyPtr->baud = baud; - ttyPtr->parity = parity; - ttyPtr->data = data; - ttyPtr->stop = stop; -} - -/* - *--------------------------------------------------------------------------- - * - * TtySetAttributes -- - * - * Set the current attributes of the specified serial device. - * - * Results: - * None. - * - * Side effects: - * None. - * - *--------------------------------------------------------------------------- - */ - -static void -TtySetAttributes(fd, ttyPtr) - int fd; /* Open file descriptor for serial port to - * be modified. */ - TtyAttrs *ttyPtr; /* Buffer containing new attributes for - * serial port. */ -{ - IOSTATE iostate; - -#ifdef USE_TERMIOS - int parity, data, flag; - - GETIOSTATE(fd, &iostate); - cfsetospeed(&iostate, TtyGetSpeed(ttyPtr->baud)); - cfsetispeed(&iostate, TtyGetSpeed(ttyPtr->baud)); - - flag = 0; - parity = ttyPtr->parity; - if (parity != 'n') { - flag |= PARENB; -#ifdef PAREXT - iostate.c_cflag &= ~PAREXT; - if ((parity == 'm') || (parity == 's')) { - flag |= PAREXT; - } -#endif - if ((parity == 'm') || (parity == 'o')) { - flag |= PARODD; - } - } - data = ttyPtr->data; - flag |= (data == 5) ? CS5 : (data == 6) ? CS6 : (data == 7) ? CS7 : CS8; - if (ttyPtr->stop == 2) { - flag |= CSTOPB; - } - - iostate.c_cflag &= ~(PARENB | PARODD | CSIZE | CSTOPB); - iostate.c_cflag |= flag; - -#endif /* USE_TERMIOS */ - -#ifdef USE_TERMIO - int parity, data, flag; - - GETIOSTATE(fd, &iostate); - iostate.c_cflag &= ~CBAUD; - iostate.c_cflag |= TtyGetSpeed(ttyPtr->baud); - - flag = 0; - parity = ttyPtr->parity; - if (parity != 'n') { - flag |= PARENB; - if ((parity == 'm') || (parity == 's')) { - flag |= PAREXT; - } - if ((parity == 'm') || (parity == 'o')) { - flag |= PARODD; - } - } - data = ttyPtr->data; - flag |= (data == 5) ? CS5 : (data == 6) ? CS6 : (data == 7) ? CS7 : CS8; - if (ttyPtr->stop == 2) { - flag |= CSTOPB; - } - - iostate.c_cflag &= ~(PARENB | PARODD | PAREXT | CSIZE | CSTOPB); - iostate.c_cflag |= flag; - -#endif /* USE_TERMIO */ - -#ifdef USE_SGTTY - int parity; - - GETIOSTATE(fd, &iostate); - iostate.sg_ospeed = TtyGetSpeed(ttyPtr->baud); - iostate.sg_ispeed = TtyGetSpeed(ttyPtr->baud); - - parity = ttyPtr->parity; - if (parity == 'e') { - iostate.sg_flags &= ~ODDP; - iostate.sg_flags |= EVENP; - } else if (parity == 'o') { - iostate.sg_flags &= ~EVENP; - iostate.sg_flags |= ODDP; - } -#endif /* USE_SGTTY */ - - SETIOSTATE(fd, &iostate); -} - -/* - *--------------------------------------------------------------------------- - * - * TtyParseMode -- - * - * Parse the "-mode" argument to the fconfigure command. The argument - * is of the form baud,parity,data,stop. - * - * Results: - * The return value is TCL_OK if the argument was successfully - * parsed, TCL_ERROR otherwise. If TCL_ERROR is returned, an - * error message is left in the interp's result (if interp is non-NULL). - * - * Side effects: - * None. - * - *--------------------------------------------------------------------------- - */ - -static int -TtyParseMode(interp, mode, speedPtr, parityPtr, dataPtr, stopPtr) - Tcl_Interp *interp; /* If non-NULL, interp for error return. */ - CONST char *mode; /* Mode string to be parsed. */ - int *speedPtr; /* Filled with baud rate from mode string. */ - int *parityPtr; /* Filled with parity from mode string. */ - int *dataPtr; /* Filled with data bits from mode string. */ - int *stopPtr; /* Filled with stop bits from mode string. */ -{ - int i, end; - char parity; - static char *bad = "bad value for -mode"; - - i = sscanf(mode, "%d,%c,%d,%d%n", speedPtr, &parity, dataPtr, - stopPtr, &end); - if ((i != 4) || (mode[end] != '\0')) { - if (interp != NULL) { - Tcl_AppendResult(interp, bad, ": should be baud,parity,data,stop", - NULL); - } - return TCL_ERROR; - } - /* - * Only allow setting mark/space parity on platforms that support it - * Make sure to allow for the case where strchr is a macro. - * [Bug: 5089] - */ - if ( -#if defined(PAREXT) || defined(USE_TERMIO) - strchr("noems", parity) == NULL -#else - strchr("noe", parity) == NULL -#endif - ) { - if (interp != NULL) { - Tcl_AppendResult(interp, bad, -#if defined(PAREXT) || defined(USE_TERMIO) - " parity: should be n, o, e, m, or s", -#else - " parity: should be n, o, or e", -#endif - NULL); - } - return TCL_ERROR; - } - *parityPtr = parity; - if ((*dataPtr < 5) || (*dataPtr > 8)) { - if (interp != NULL) { - Tcl_AppendResult(interp, bad, " data: should be 5, 6, 7, or 8", - NULL); - } - return TCL_ERROR; - } - if ((*stopPtr < 0) || (*stopPtr > 2)) { - if (interp != NULL) { - Tcl_AppendResult(interp, bad, " stop: should be 1 or 2", NULL); - } - return TCL_ERROR; - } - return TCL_OK; -} - -/* - *--------------------------------------------------------------------------- - * - * TtyInit -- - * - * Given file descriptor that refers to a serial port, - * initialize the serial port to a set of sane values so that - * Tcl can talk to a device located on the serial port. - * - * Results: - * None. - * - * Side effects: - * Serial device initialized to non-blocking raw mode, similar to - * sockets. All other modes can be simulated on top of this in Tcl. - * - *--------------------------------------------------------------------------- - */ - -static FileState * -TtyInit(fd) - int fd; /* Open file descriptor for serial port to - * be initialized. */ -{ - IOSTATE iostate; - TtyState *ttyPtr; - - ttyPtr = (TtyState *) ckalloc((unsigned) sizeof(TtyState)); - GETIOSTATE(fd, &ttyPtr->savedState); - - iostate = ttyPtr->savedState; - -#ifdef USE_TERMIOS - iostate.c_iflag = IGNBRK; - iostate.c_oflag = 0; - iostate.c_lflag = 0; - iostate.c_cflag |= CREAD; - iostate.c_cc[VMIN] = 1; - iostate.c_cc[VTIME] = 0; -#endif /* USE_TERMIOS */ - -#ifdef USE_TERMIO - iostate.c_iflag = IGNBRK; - iostate.c_oflag = 0; - iostate.c_lflag = 0; - iostate.c_cflag |= CREAD; - iostate.c_cc[VMIN] = 1; - iostate.c_cc[VTIME] = 0; -#endif /* USE_TERMIO */ - -#ifdef USE_SGTTY - iostate.sg_flags &= (EVENP | ODDP); - iostate.sg_flags |= RAW; -#endif /* USE_SGTTY */ - - SETIOSTATE(fd, &iostate); - - return &ttyPtr->fs; -} -#endif /* SUPPORTS_TTY */ - -/* - *---------------------------------------------------------------------- - * - * TclpOpenFileChannel -- - * - * Open an file based channel on Unix systems. - * - * Results: - * The new channel or NULL. If NULL, the output argument - * errorCodePtr is set to a POSIX error and an error message is - * left in the interp's result if interp is not NULL. - * - * Side effects: - * May open the channel and may cause creation of a file on the - * file system. - * - *---------------------------------------------------------------------- - */ - -Tcl_Channel -TclpOpenFileChannel(interp, fileName, modeString, permissions) - Tcl_Interp *interp; /* Interpreter for error reporting; - * can be NULL. */ - char *fileName; /* Name of file to open. */ - char *modeString; /* A list of POSIX open modes or - * a string such as "rw". */ - int permissions; /* If the open involves creating a - * file, with what modes to create - * it? */ -{ - int fd, seekFlag, mode, channelPermissions; - FileState *fsPtr; - char *native, *translation; - char channelName[16 + TCL_INTEGER_SPACE]; - Tcl_DString ds, buffer; - Tcl_ChannelType *channelTypePtr; - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - - mode = TclGetOpenMode(interp, modeString, &seekFlag); - if (mode == -1) { - return NULL; - } - switch (mode & (O_RDONLY | O_WRONLY | O_RDWR)) { - case O_RDONLY: - channelPermissions = TCL_READABLE; - break; - case O_WRONLY: - channelPermissions = TCL_WRITABLE; - break; - case O_RDWR: - channelPermissions = (TCL_READABLE | TCL_WRITABLE); - break; - default: - /* - * This may occurr if modeString was "", for example. - */ - panic("TclpOpenFileChannel: invalid mode value"); - return NULL; - } - - native = Tcl_TranslateFileName(interp, fileName, &buffer); - if (native == NULL) { - return NULL; - } - native = Tcl_UtfToExternalDString(NULL, native, -1, &ds); - fd = open(native, mode, permissions); /* INTL: Native. */ - Tcl_DStringFree(&ds); - Tcl_DStringFree(&buffer); - - if (fd < 0) { - if (interp != (Tcl_Interp *) NULL) { - Tcl_AppendResult(interp, "couldn't open \"", fileName, "\": ", - Tcl_PosixError(interp), (char *) NULL); - } - return NULL; - } - - /* - * Set close-on-exec flag on the fd so that child processes will not - * inherit this fd. - */ - - fcntl(fd, F_SETFD, FD_CLOEXEC); - - sprintf(channelName, "file%d", fd); - -#ifdef SUPPORTS_TTY - if (isatty(fd)) { - /* - * Initialize the serial port to a set of sane parameters. - * Especially important if the remote device is set to echo and - * the serial port driver was also set to echo -- as soon as a char - * were sent to the serial port, the remote device would echo it, - * then the serial driver would echo it back to the device, etc. - */ - - translation = "auto crlf"; - channelTypePtr = &ttyChannelType; - fsPtr = TtyInit(fd); - } else -#endif /* SUPPORTS_TTY */ - { - translation = NULL; - channelTypePtr = &fileChannelType; - fsPtr = (FileState *) ckalloc((unsigned) sizeof(FileState)); - } - - fsPtr->nextPtr = tsdPtr->firstFilePtr; - tsdPtr->firstFilePtr = fsPtr; - fsPtr->validMask = channelPermissions | TCL_EXCEPTION; - fsPtr->fd = fd; - - fsPtr->channel = Tcl_CreateChannel(channelTypePtr, channelName, - (ClientData) fsPtr, channelPermissions); - - if (seekFlag) { - if (Tcl_Seek(fsPtr->channel, 0, SEEK_END) < 0) { - if (interp != (Tcl_Interp *) NULL) { - Tcl_AppendResult(interp, "couldn't seek to end of file on \"", - channelName, "\": ", Tcl_PosixError(interp), NULL); - } - Tcl_Close(NULL, fsPtr->channel); - return NULL; - } - } - - if (translation != NULL) { - /* - * Gotcha. Most modems need a "\r" at the end of the command - * sequence. If you just send "at\n", the modem will not respond - * with "OK" because it never got a "\r" to actually invoke the - * command. So, by default, newlines are translated to "\r\n" on - * output to avoid "bug" reports that the serial port isn't working. - */ - - if (Tcl_SetChannelOption(interp, fsPtr->channel, "-translation", - translation) != TCL_OK) { - Tcl_Close(NULL, fsPtr->channel); - return NULL; - } - } - - return fsPtr->channel; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_MakeFileChannel -- - * - * Makes a Tcl_Channel from an existing OS level file handle. - * - * Results: - * The Tcl_Channel created around the preexisting OS level file handle. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -Tcl_Channel -Tcl_MakeFileChannel(handle, mode) - ClientData handle; /* OS level handle. */ - int mode; /* ORed combination of TCL_READABLE and - * TCL_WRITABLE to indicate file mode. */ -{ - FileState *fsPtr; - char channelName[16 + TCL_INTEGER_SPACE]; - int fd = (int) handle; - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - - if (mode == 0) { - return NULL; - } - - sprintf(channelName, "file%d", fd); - - /* - * Look to see if a channel with this fd and the same mode already exists. - * If the fd is used, but the mode doesn't match, return NULL. - */ - - for (fsPtr = tsdPtr->firstFilePtr; fsPtr != NULL; fsPtr = fsPtr->nextPtr) { - if (fsPtr->fd == fd) { - return ((mode|TCL_EXCEPTION) == fsPtr->validMask) ? - fsPtr->channel : NULL; - } - } - - fsPtr = (FileState *) ckalloc((unsigned) sizeof(FileState)); - fsPtr->nextPtr = tsdPtr->firstFilePtr; - tsdPtr->firstFilePtr = fsPtr; - - fsPtr->fd = fd; - fsPtr->validMask = mode | TCL_EXCEPTION; - fsPtr->channel = Tcl_CreateChannel(&fileChannelType, channelName, - (ClientData) fsPtr, mode); - - return fsPtr->channel; -} - -/* - *---------------------------------------------------------------------- - * - * TcpBlockModeProc -- - * - * This procedure is invoked by the generic IO level to set blocking - * and nonblocking mode on a TCP socket based channel. - * - * Results: - * 0 if successful, errno when failed. - * - * Side effects: - * Sets the device into blocking or nonblocking mode. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -static int -TcpBlockModeProc(instanceData, mode) - ClientData instanceData; /* Socket state. */ - int mode; /* The mode to set. Can be one of - * TCL_MODE_BLOCKING or - * TCL_MODE_NONBLOCKING. */ -{ - TcpState *statePtr = (TcpState *) instanceData; - int setting; - -#ifndef USE_FIONBIO - setting = fcntl(statePtr->fd, F_GETFL); - if (mode == TCL_MODE_BLOCKING) { - statePtr->flags &= (~(TCP_ASYNC_SOCKET)); - setting &= (~(O_NONBLOCK)); - } else { - statePtr->flags |= TCP_ASYNC_SOCKET; - setting |= O_NONBLOCK; - } - if (fcntl(statePtr->fd, F_SETFL, setting) < 0) { - return errno; - } -#endif - -#ifdef USE_FIONBIO - if (mode == TCL_MODE_BLOCKING) { - statePtr->flags &= (~(TCP_ASYNC_SOCKET)); - setting = 0; - if (ioctl(statePtr->fd, (int) FIONBIO, &setting) == -1) { - return errno; - } - } else { - statePtr->flags |= TCP_ASYNC_SOCKET; - setting = 1; - if (ioctl(statePtr->fd, (int) FIONBIO, &setting) == -1) { - return errno; - } - } -#endif - - return 0; -} - -/* - *---------------------------------------------------------------------- - * - * WaitForConnect -- - * - * Waits for a connection on an asynchronously opened socket to - * be completed. - * - * Results: - * None. - * - * Side effects: - * The socket is connected after this function returns. - * - *---------------------------------------------------------------------- - */ - -static int -WaitForConnect(statePtr, errorCodePtr) - TcpState *statePtr; /* State of the socket. */ - int *errorCodePtr; /* Where to store errors? */ -{ - int timeOut; /* How long to wait. */ - int state; /* Of calling TclWaitForFile. */ - int flags; /* fcntl flags for the socket. */ - - /* - * If an asynchronous connect is in progress, attempt to wait for it - * to complete before reading. - */ - - if (statePtr->flags & TCP_ASYNC_CONNECT) { - if (statePtr->flags & TCP_ASYNC_SOCKET) { - timeOut = 0; - } else { - timeOut = -1; - } - errno = 0; - state = TclUnixWaitForFile(statePtr->fd, - TCL_WRITABLE | TCL_EXCEPTION, timeOut); - if (!(statePtr->flags & TCP_ASYNC_SOCKET)) { -#ifndef USE_FIONBIO - flags = fcntl(statePtr->fd, F_GETFL); - flags &= (~(O_NONBLOCK)); - (void) fcntl(statePtr->fd, F_SETFL, flags); -#endif - -#ifdef USE_FIONBIO - flags = 0; - (void) ioctl(statePtr->fd, FIONBIO, &flags); -#endif - } - if (state & TCL_EXCEPTION) { - return -1; - } - if (state & TCL_WRITABLE) { - statePtr->flags &= (~(TCP_ASYNC_CONNECT)); - } else if (timeOut == 0) { - *errorCodePtr = errno = EWOULDBLOCK; - return -1; - } - } - return 0; -} - -/* - *---------------------------------------------------------------------- - * - * TcpInputProc -- - * - * This procedure is invoked by the generic IO level to read input - * from a TCP socket based channel. - * - * NOTE: We cannot share code with FilePipeInputProc because here - * we must use recv to obtain the input from the channel, not read. - * - * Results: - * The number of bytes read is returned or -1 on error. An output - * argument contains the POSIX error code on error, or zero if no - * error occurred. - * - * Side effects: - * Reads input from the input device of the channel. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -static int -TcpInputProc(instanceData, buf, bufSize, errorCodePtr) - ClientData instanceData; /* Socket state. */ - char *buf; /* Where to store data read. */ - int bufSize; /* How much space is available - * in the buffer? */ - int *errorCodePtr; /* Where to store error code. */ -{ - TcpState *statePtr = (TcpState *) instanceData; - int bytesRead, state; - - *errorCodePtr = 0; - state = WaitForConnect(statePtr, errorCodePtr); - if (state != 0) { - return -1; - } - bytesRead = recv(statePtr->fd, buf, (size_t) bufSize, 0); - if (bytesRead > -1) { - return bytesRead; - } - if (errno == ECONNRESET) { - - /* - * Turn ECONNRESET into a soft EOF condition. - */ - - return 0; - } - *errorCodePtr = errno; - return -1; -} - -/* - *---------------------------------------------------------------------- - * - * TcpOutputProc -- - * - * This procedure is invoked by the generic IO level to write output - * to a TCP socket based channel. - * - * NOTE: We cannot share code with FilePipeOutputProc because here - * we must use send, not write, to get reliable error reporting. - * - * Results: - * The number of bytes written is returned. An output argument is - * set to a POSIX error code if an error occurred, or zero. - * - * Side effects: - * Writes output on the output device of the channel. - * - *---------------------------------------------------------------------- - */ - -static int -TcpOutputProc(instanceData, buf, toWrite, errorCodePtr) - ClientData instanceData; /* Socket state. */ - char *buf; /* The data buffer. */ - int toWrite; /* How many bytes to write? */ - int *errorCodePtr; /* Where to store error code. */ -{ - TcpState *statePtr = (TcpState *) instanceData; - int written; - int state; /* Of waiting for connection. */ - - *errorCodePtr = 0; - state = WaitForConnect(statePtr, errorCodePtr); - if (state != 0) { - return -1; - } - written = send(statePtr->fd, buf, (size_t) toWrite, 0); - if (written > -1) { - return written; - } - *errorCodePtr = errno; - return -1; -} - -/* - *---------------------------------------------------------------------- - * - * TcpCloseProc -- - * - * This procedure is invoked by the generic IO level to perform - * channel-type-specific cleanup when a TCP socket based channel - * is closed. - * - * Results: - * 0 if successful, the value of errno if failed. - * - * Side effects: - * Closes the socket of the channel. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -static int -TcpCloseProc(instanceData, interp) - ClientData instanceData; /* The socket to close. */ - Tcl_Interp *interp; /* For error reporting - unused. */ -{ - TcpState *statePtr = (TcpState *) instanceData; - int errorCode = 0; - - /* - * Delete a file handler that may be active for this socket if this - * is a server socket - the file handler was created automatically - * by Tcl as part of the mechanism to accept new client connections. - * Channel handlers are already deleted in the generic IO channel - * closing code that called this function, so we do not have to - * delete them here. - */ - - Tcl_DeleteFileHandler(statePtr->fd); - - if (close(statePtr->fd) < 0) { - errorCode = errno; - } - ckfree((char *) statePtr); - - return errorCode; -} - -/* - *---------------------------------------------------------------------- - * - * TcpGetOptionProc -- - * - * Computes an option value for a TCP socket based channel, or a - * list of all options and their values. - * - * Note: This code is based on code contributed by John Haxby. - * - * Results: - * A standard Tcl result. The value of the specified option or a - * list of all options and their values is returned in the - * supplied DString. Sets Error message if needed. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -TcpGetOptionProc(instanceData, interp, optionName, dsPtr) - ClientData instanceData; /* Socket state. */ - Tcl_Interp *interp; /* For error reporting - can be NULL. */ - char *optionName; /* Name of the option to - * retrieve the value for, or - * NULL to get all options and - * their values. */ - Tcl_DString *dsPtr; /* Where to store the computed - * value; initialized by caller. */ -{ - TcpState *statePtr = (TcpState *) instanceData; - struct sockaddr_in sockname; - struct sockaddr_in peername; - struct hostent *hostEntPtr; - int size = sizeof(struct sockaddr_in); - size_t len = 0; - char buf[TCL_INTEGER_SPACE]; - - if (optionName != (char *) NULL) { - len = strlen(optionName); - } - - if ((len > 1) && (optionName[1] == 'e') && - (strncmp(optionName, "-error", len) == 0)) { - int optlen; - int err, ret; - - optlen = sizeof(int); - ret = getsockopt(statePtr->fd, SOL_SOCKET, SO_ERROR, - (char *)&err, &optlen); - if (ret < 0) { - err = errno; - } - if (err != 0) { - Tcl_DStringAppend(dsPtr, Tcl_ErrnoMsg(err), -1); - } - return TCL_OK; - } - - if ((len == 0) || - ((len > 1) && (optionName[1] == 'p') && - (strncmp(optionName, "-peername", len) == 0))) { - if (getpeername(statePtr->fd, (struct sockaddr *) &peername, - &size) >= 0) { - if (len == 0) { - Tcl_DStringAppendElement(dsPtr, "-peername"); - Tcl_DStringStartSublist(dsPtr); - } - Tcl_DStringAppendElement(dsPtr, inet_ntoa(peername.sin_addr)); - hostEntPtr = gethostbyaddr( /* INTL: Native. */ - (char *) &peername.sin_addr, - sizeof(peername.sin_addr), AF_INET); - if (hostEntPtr != NULL) { - Tcl_DString ds; - - Tcl_ExternalToUtfDString(NULL, hostEntPtr->h_name, -1, &ds); - Tcl_DStringAppendElement(dsPtr, Tcl_DStringValue(&ds)); - } else { - Tcl_DStringAppendElement(dsPtr, inet_ntoa(peername.sin_addr)); - } - TclFormatInt(buf, ntohs(peername.sin_port)); - Tcl_DStringAppendElement(dsPtr, buf); - if (len == 0) { - Tcl_DStringEndSublist(dsPtr); - } else { - return TCL_OK; - } - } else { - /* - * getpeername failed - but if we were asked for all the options - * (len==0), don't flag an error at that point because it could - * be an fconfigure request on a server socket. (which have - * no peer). same must be done on win&mac. - */ - - if (len) { - if (interp) { - Tcl_AppendResult(interp, "can't get peername: ", - Tcl_PosixError(interp), - (char *) NULL); - } - return TCL_ERROR; - } - } - } - - if ((len == 0) || - ((len > 1) && (optionName[1] == 's') && - (strncmp(optionName, "-sockname", len) == 0))) { - if (getsockname(statePtr->fd, (struct sockaddr *) &sockname, &size) - >= 0) { - if (len == 0) { - Tcl_DStringAppendElement(dsPtr, "-sockname"); - Tcl_DStringStartSublist(dsPtr); - } - Tcl_DStringAppendElement(dsPtr, inet_ntoa(sockname.sin_addr)); - hostEntPtr = gethostbyaddr( /* INTL: Native. */ - (char *) &sockname.sin_addr, - sizeof(sockname.sin_addr), AF_INET); - if (hostEntPtr != (struct hostent *) NULL) { - Tcl_DString ds; - - Tcl_ExternalToUtfDString(NULL, hostEntPtr->h_name, -1, &ds); - Tcl_DStringAppendElement(dsPtr, Tcl_DStringValue(&ds)); - } else { - Tcl_DStringAppendElement(dsPtr, inet_ntoa(sockname.sin_addr)); - } - TclFormatInt(buf, ntohs(sockname.sin_port)); - Tcl_DStringAppendElement(dsPtr, buf); - if (len == 0) { - Tcl_DStringEndSublist(dsPtr); - } else { - return TCL_OK; - } - } else { - if (interp) { - Tcl_AppendResult(interp, "can't get sockname: ", - Tcl_PosixError(interp), - (char *) NULL); - } - return TCL_ERROR; - } - } - - if (len > 0) { - return Tcl_BadChannelOption(interp, optionName, "peername sockname"); - } - - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TcpWatchProc -- - * - * Initialize the notifier to watch the fd from this channel. - * - * Results: - * None. - * - * Side effects: - * Sets up the notifier so that a future event on the channel will - * be seen by Tcl. - * - *---------------------------------------------------------------------- - */ - -static void -TcpWatchProc(instanceData, mask) - ClientData instanceData; /* The socket state. */ - int mask; /* Events of interest; an OR-ed - * combination of TCL_READABLE, - * TCL_WRITABLE and TCL_EXCEPTION. */ -{ - TcpState *statePtr = (TcpState *) instanceData; - - /* - * Make sure we don't mess with server sockets since they will never - * be readable or writable at the Tcl level. This keeps Tcl scripts - * from interfering with the -accept behavior. - */ - - if (!statePtr->acceptProc) { - if (mask) { - Tcl_CreateFileHandler(statePtr->fd, mask, - (Tcl_FileProc *) Tcl_NotifyChannel, - (ClientData) statePtr->channel); - } else { - Tcl_DeleteFileHandler(statePtr->fd); - } - } -} - -/* - *---------------------------------------------------------------------- - * - * TcpGetHandleProc -- - * - * Called from Tcl_GetChannelHandle to retrieve OS handles from inside - * a TCP socket based channel. - * - * Results: - * Returns TCL_OK with the fd in handlePtr, or TCL_ERROR if - * there is no handle for the specified direction. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -static int -TcpGetHandleProc(instanceData, direction, handlePtr) - ClientData instanceData; /* The socket state. */ - int direction; /* Not used. */ - ClientData *handlePtr; /* Where to store the handle. */ -{ - TcpState *statePtr = (TcpState *) instanceData; - - *handlePtr = (ClientData)statePtr->fd; - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * CreateSocket -- - * - * This function opens a new socket in client or server mode - * and initializes the TcpState structure. - * - * Results: - * Returns a new TcpState, or NULL with an error in the interp's - * result, if interp is not NULL. - * - * Side effects: - * Opens a socket. - * - *---------------------------------------------------------------------- - */ - -static TcpState * -CreateSocket(interp, port, host, server, myaddr, myport, async) - Tcl_Interp *interp; /* For error reporting; can be NULL. */ - int port; /* Port number to open. */ - char *host; /* Name of host on which to open port. - * NULL implies INADDR_ANY */ - int server; /* 1 if socket should be a server socket, - * else 0 for a client socket. */ - char *myaddr; /* Optional client-side address */ - int myport; /* Optional client-side port */ - int async; /* If nonzero and creating a client socket, - * attempt to do an async connect. Otherwise - * do a synchronous connect or bind. */ -{ - int status, sock, asyncConnect, curState, origState; - struct sockaddr_in sockaddr; /* socket address */ - struct sockaddr_in mysockaddr; /* Socket address for client */ - TcpState *statePtr; - - sock = -1; - origState = 0; - if (! CreateSocketAddress(&sockaddr, host, port)) { - goto addressError; - } - if ((myaddr != NULL || myport != 0) && - ! CreateSocketAddress(&mysockaddr, myaddr, myport)) { - goto addressError; - } - - sock = socket(AF_INET, SOCK_STREAM, 0); - if (sock < 0) { - goto addressError; - } - - /* - * Set the close-on-exec flag so that the socket will not get - * inherited by child processes. - */ - - fcntl(sock, F_SETFD, FD_CLOEXEC); - - /* - * Set kernel space buffering - */ - - TclSockMinimumBuffers(sock, SOCKET_BUFSIZE); - - asyncConnect = 0; - status = 0; - if (server) { - - /* - * Set up to reuse server addresses automatically and bind to the - * specified port. - */ - - status = 1; - (void) setsockopt(sock, SOL_SOCKET, SO_REUSEADDR, (char *) &status, - sizeof(status)); - status = bind(sock, (struct sockaddr *) &sockaddr, - sizeof(struct sockaddr)); - if (status != -1) { - status = listen(sock, SOMAXCONN); - } - } else { - if (myaddr != NULL || myport != 0) { - curState = 1; - (void) setsockopt(sock, SOL_SOCKET, SO_REUSEADDR, - (char *) &curState, sizeof(curState)); - status = bind(sock, (struct sockaddr *) &mysockaddr, - sizeof(struct sockaddr)); - if (status < 0) { - goto bindError; - } - } - - /* - * Attempt to connect. The connect may fail at present with an - * EINPROGRESS but at a later time it will complete. The caller - * will set up a file handler on the socket if she is interested in - * being informed when the connect completes. - */ - - if (async) { -#ifndef USE_FIONBIO - origState = fcntl(sock, F_GETFL); - curState = origState | O_NONBLOCK; - status = fcntl(sock, F_SETFL, curState); -#endif - -#ifdef USE_FIONBIO - curState = 1; - status = ioctl(sock, FIONBIO, &curState); -#endif - } else { - status = 0; - } - if (status > -1) { - status = connect(sock, (struct sockaddr *) &sockaddr, - sizeof(sockaddr)); - if (status < 0) { - if (errno == EINPROGRESS) { - asyncConnect = 1; - status = 0; - } - } else { - /* - * Here we are if the connect succeeds. In case of an - * asynchronous connect we have to reset the channel to - * blocking mode. This appears to happen not very often, - * but e.g. on a HP 9000/800 under HP-UX B.11.00 we enter - * this stage. [Bug: 4388] - */ - if (async) { -#ifndef USE_FIONBIO - origState = fcntl(sock, F_GETFL); - curState = origState & ~(O_NONBLOCK); - status = fcntl(sock, F_SETFL, curState); -#endif - -#ifdef USE_FIONBIO - curState = 0; - status = ioctl(sock, FIONBIO, &curState); -#endif - } - } - } - } - -bindError: - if (status < 0) { - if (interp != NULL) { - Tcl_AppendResult(interp, "couldn't open socket: ", - Tcl_PosixError(interp), (char *) NULL); - } - if (sock != -1) { - close(sock); - } - return NULL; - } - - /* - * Allocate a new TcpState for this socket. - */ - - statePtr = (TcpState *) ckalloc((unsigned) sizeof(TcpState)); - statePtr->flags = 0; - if (asyncConnect) { - statePtr->flags = TCP_ASYNC_CONNECT; - } - statePtr->fd = sock; - - return statePtr; - -addressError: - if (sock != -1) { - close(sock); - } - if (interp != NULL) { - Tcl_AppendResult(interp, "couldn't open socket: ", - Tcl_PosixError(interp), (char *) NULL); - } - return NULL; -} - -/* - *---------------------------------------------------------------------- - * - * CreateSocketAddress -- - * - * This function initializes a sockaddr structure for a host and port. - * - * Results: - * 1 if the host was valid, 0 if the host could not be converted to - * an IP address. - * - * Side effects: - * Fills in the *sockaddrPtr structure. - * - *---------------------------------------------------------------------- - */ - -static int -CreateSocketAddress(sockaddrPtr, host, port) - struct sockaddr_in *sockaddrPtr; /* Socket address */ - char *host; /* Host. NULL implies INADDR_ANY */ - int port; /* Port number */ -{ - struct hostent *hostent; /* Host database entry */ - struct in_addr addr; /* For 64/32 bit madness */ - - (void) memset((VOID *) sockaddrPtr, '\0', sizeof(struct sockaddr_in)); - sockaddrPtr->sin_family = AF_INET; - sockaddrPtr->sin_port = htons((unsigned short) (port & 0xFFFF)); - if (host == NULL) { - addr.s_addr = INADDR_ANY; - } else { - Tcl_DString ds; - CONST char *native; - - if (host == NULL) { - native = NULL; - } else { - native = Tcl_UtfToExternalDString(NULL, host, -1, &ds); - } - addr.s_addr = inet_addr(native); /* INTL: Native. */ - /* - * This is 0xFFFFFFFF to ensure that it compares as a 32bit -1 - * on either 32 or 64 bits systems. - */ - if (addr.s_addr == 0xFFFFFFFF) { - hostent = gethostbyname(native); /* INTL: Native. */ - if (hostent != NULL) { - memcpy((VOID *) &addr, - (VOID *) hostent->h_addr_list[0], - (size_t) hostent->h_length); - } else { -#ifdef EHOSTUNREACH - errno = EHOSTUNREACH; -#else -#ifdef ENXIO - errno = ENXIO; -#endif -#endif - if (native != NULL) { - Tcl_DStringFree(&ds); - } - return 0; /* error */ - } - } - if (native != NULL) { - Tcl_DStringFree(&ds); - } - } - - /* - * NOTE: On 64 bit machines the assignment below is rumored to not - * do the right thing. Please report errors related to this if you - * observe incorrect behavior on 64 bit machines such as DEC Alphas. - * Should we modify this code to do an explicit memcpy? - */ - - sockaddrPtr->sin_addr.s_addr = addr.s_addr; - return 1; /* Success. */ -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_OpenTcpClient -- - * - * Opens a TCP client socket and creates a channel around it. - * - * Results: - * The channel or NULL if failed. An error message is returned - * in the interpreter on failure. - * - * Side effects: - * Opens a client socket and creates a new channel. - * - *---------------------------------------------------------------------- - */ - -Tcl_Channel -Tcl_OpenTcpClient(interp, port, host, myaddr, myport, async) - Tcl_Interp *interp; /* For error reporting; can be NULL. */ - int port; /* Port number to open. */ - char *host; /* Host on which to open port. */ - char *myaddr; /* Client-side address */ - int myport; /* Client-side port */ - int async; /* If nonzero, attempt to do an - * asynchronous connect. Otherwise - * we do a blocking connect. */ -{ - TcpState *statePtr; - char channelName[16 + TCL_INTEGER_SPACE]; - - /* - * Create a new client socket and wrap it in a channel. - */ - - statePtr = CreateSocket(interp, port, host, 0, myaddr, myport, async); - if (statePtr == NULL) { - return NULL; - } - - statePtr->acceptProc = NULL; - statePtr->acceptProcData = (ClientData) NULL; - - sprintf(channelName, "sock%d", statePtr->fd); - - statePtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName, - (ClientData) statePtr, (TCL_READABLE | TCL_WRITABLE)); - if (Tcl_SetChannelOption(interp, statePtr->channel, "-translation", - "auto crlf") == TCL_ERROR) { - Tcl_Close((Tcl_Interp *) NULL, statePtr->channel); - return NULL; - } - return statePtr->channel; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_MakeTcpClientChannel -- - * - * Creates a Tcl_Channel from an existing client TCP socket. - * - * Results: - * The Tcl_Channel wrapped around the preexisting TCP socket. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -Tcl_Channel -Tcl_MakeTcpClientChannel(sock) - ClientData sock; /* The socket to wrap up into a channel. */ -{ - TcpState *statePtr; - char channelName[16 + TCL_INTEGER_SPACE]; - - statePtr = (TcpState *) ckalloc((unsigned) sizeof(TcpState)); - statePtr->fd = (int) sock; - statePtr->acceptProc = NULL; - statePtr->acceptProcData = (ClientData) NULL; - - sprintf(channelName, "sock%d", statePtr->fd); - - statePtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName, - (ClientData) statePtr, (TCL_READABLE | TCL_WRITABLE)); - if (Tcl_SetChannelOption((Tcl_Interp *) NULL, statePtr->channel, - "-translation", "auto crlf") == TCL_ERROR) { - Tcl_Close((Tcl_Interp *) NULL, statePtr->channel); - return NULL; - } - return statePtr->channel; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_OpenTcpServer -- - * - * Opens a TCP server socket and creates a channel around it. - * - * Results: - * The channel or NULL if failed. If an error occurred, an - * error message is left in the interp's result if interp is - * not NULL. - * - * Side effects: - * Opens a server socket and creates a new channel. - * - *---------------------------------------------------------------------- - */ - -Tcl_Channel -Tcl_OpenTcpServer(interp, port, myHost, acceptProc, acceptProcData) - Tcl_Interp *interp; /* For error reporting - may be - * NULL. */ - int port; /* Port number to open. */ - char *myHost; /* Name of local host. */ - Tcl_TcpAcceptProc *acceptProc; /* Callback for accepting connections - * from new clients. */ - ClientData acceptProcData; /* Data for the callback. */ -{ - TcpState *statePtr; - char channelName[16 + TCL_INTEGER_SPACE]; - - /* - * Create a new client socket and wrap it in a channel. - */ - - statePtr = CreateSocket(interp, port, myHost, 1, NULL, 0, 0); - if (statePtr == NULL) { - return NULL; - } - - statePtr->acceptProc = acceptProc; - statePtr->acceptProcData = acceptProcData; - - /* - * Set up the callback mechanism for accepting connections - * from new clients. - */ - - Tcl_CreateFileHandler(statePtr->fd, TCL_READABLE, TcpAccept, - (ClientData) statePtr); - sprintf(channelName, "sock%d", statePtr->fd); - statePtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName, - (ClientData) statePtr, 0); - return statePtr->channel; -} - -/* - *---------------------------------------------------------------------- - * - * TcpAccept -- - * Accept a TCP socket connection. This is called by the event loop. - * - * Results: - * None. - * - * Side effects: - * Creates a new connection socket. Calls the registered callback - * for the connection acceptance mechanism. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -static void -TcpAccept(data, mask) - ClientData data; /* Callback token. */ - int mask; /* Not used. */ -{ - TcpState *sockState; /* Client data of server socket. */ - int newsock; /* The new client socket */ - TcpState *newSockState; /* State for new socket. */ - struct sockaddr_in addr; /* The remote address */ - int len; /* For accept interface */ - char channelName[16 + TCL_INTEGER_SPACE]; - - sockState = (TcpState *) data; - - len = sizeof(struct sockaddr_in); - newsock = accept(sockState->fd, (struct sockaddr *) &addr, &len); - if (newsock < 0) { - return; - } - - /* - * Set close-on-exec flag to prevent the newly accepted socket from - * being inherited by child processes. - */ - - (void) fcntl(newsock, F_SETFD, FD_CLOEXEC); - - newSockState = (TcpState *) ckalloc((unsigned) sizeof(TcpState)); - - newSockState->flags = 0; - newSockState->fd = newsock; - newSockState->acceptProc = NULL; - newSockState->acceptProcData = NULL; - - sprintf(channelName, "sock%d", newsock); - newSockState->channel = Tcl_CreateChannel(&tcpChannelType, channelName, - (ClientData) newSockState, (TCL_READABLE | TCL_WRITABLE)); - - Tcl_SetChannelOption(NULL, newSockState->channel, "-translation", - "auto crlf"); - - if (sockState->acceptProc != NULL) { - (*sockState->acceptProc)(sockState->acceptProcData, - newSockState->channel, inet_ntoa(addr.sin_addr), - ntohs(addr.sin_port)); - } -} - -/* - *---------------------------------------------------------------------- - * - * TclpGetDefaultStdChannel -- - * - * Creates channels for standard input, standard output or standard - * error output if they do not already exist. - * - * Results: - * Returns the specified default standard channel, or NULL. - * - * Side effects: - * May cause the creation of a standard channel and the underlying - * file. - * - *---------------------------------------------------------------------- - */ - -Tcl_Channel -TclpGetDefaultStdChannel(type) - int type; /* One of TCL_STDIN, TCL_STDOUT, TCL_STDERR. */ -{ - Tcl_Channel channel = NULL; - int fd = 0; /* Initializations needed to prevent */ - int mode = 0; /* compiler warning (used before set). */ - char *bufMode = NULL; - - switch (type) { - case TCL_STDIN: - if ((lseek(0, (off_t) 0, SEEK_CUR) == -1) && - (errno == EBADF)) { - return (Tcl_Channel) NULL; - } - fd = 0; - mode = TCL_READABLE; - bufMode = "line"; - break; - case TCL_STDOUT: - if ((lseek(1, (off_t) 0, SEEK_CUR) == -1) && - (errno == EBADF)) { - return (Tcl_Channel) NULL; - } - fd = 1; - mode = TCL_WRITABLE; - bufMode = "line"; - break; - case TCL_STDERR: - if ((lseek(2, (off_t) 0, SEEK_CUR) == -1) && - (errno == EBADF)) { - return (Tcl_Channel) NULL; - } - fd = 2; - mode = TCL_WRITABLE; - bufMode = "none"; - break; - default: - panic("TclGetDefaultStdChannel: Unexpected channel type"); - break; - } - - channel = Tcl_MakeFileChannel((ClientData) fd, mode); - if (channel == NULL) { - return NULL; - } - - /* - * Set up the normal channel options for stdio handles. - */ - - Tcl_SetChannelOption(NULL, channel, "-translation", "auto"); - Tcl_SetChannelOption(NULL, channel, "-buffering", bufMode); - return channel; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_GetOpenFile -- - * - * Given a name of a channel registered in the given interpreter, - * returns a FILE * for it. - * - * Results: - * A standard Tcl result. If the channel is registered in the given - * interpreter and it is managed by the "file" channel driver, and - * it is open for the requested mode, then the output parameter - * filePtr is set to a FILE * for the underlying file. On error, the - * filePtr is not set, TCL_ERROR is returned and an error message is - * left in the interp's result. - * - * Side effects: - * May invoke fdopen to create the FILE * for the requested file. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_GetOpenFile(interp, string, forWriting, checkUsage, filePtr) - Tcl_Interp *interp; /* Interpreter in which to find file. */ - char *string; /* String that identifies file. */ - int forWriting; /* 1 means the file is going to be used - * for writing, 0 means for reading. */ - int checkUsage; /* 1 means verify that the file was opened - * in a mode that allows the access specified - * by "forWriting". Ignored, we always - * check that the channel is open for the - * requested mode. */ - ClientData *filePtr; /* Store pointer to FILE structure here. */ -{ - Tcl_Channel chan; - int chanMode; - Tcl_ChannelType *chanTypePtr; - ClientData data; - int fd; - FILE *f; - - chan = Tcl_GetChannel(interp, string, &chanMode); - if (chan == (Tcl_Channel) NULL) { - return TCL_ERROR; - } - if ((forWriting) && ((chanMode & TCL_WRITABLE) == 0)) { - Tcl_AppendResult(interp, - "\"", string, "\" wasn't opened for writing", (char *) NULL); - return TCL_ERROR; - } else if ((!(forWriting)) && ((chanMode & TCL_READABLE) == 0)) { - Tcl_AppendResult(interp, - "\"", string, "\" wasn't opened for reading", (char *) NULL); - return TCL_ERROR; - } - - /* - * We allow creating a FILE * out of file based, pipe based and socket - * based channels. We currently do not allow any other channel types, - * because it is likely that stdio will not know what to do with them. - */ - - chanTypePtr = Tcl_GetChannelType(chan); - if ((chanTypePtr == &fileChannelType) -#ifdef SUPPORTS_TTY - || (chanTypePtr == &ttyChannelType) -#endif /* SUPPORTS_TTY */ - || (chanTypePtr == &tcpChannelType) - || (strcmp(chanTypePtr->typeName, "pipe") == 0)) { - if (Tcl_GetChannelHandle(chan, - (forWriting ? TCL_WRITABLE : TCL_READABLE), - (ClientData*) &data) == TCL_OK) { - fd = (int) data; - - /* - * The call to fdopen below is probably dangerous, since it will - * truncate an existing file if the file is being opened - * for writing.... - */ - - f = fdopen(fd, (forWriting ? "w" : "r")); - if (f == NULL) { - Tcl_AppendResult(interp, "cannot get a FILE * for \"", string, - "\"", (char *) NULL); - return TCL_ERROR; - } - *filePtr = (ClientData) f; - return TCL_OK; - } - } - - Tcl_AppendResult(interp, "\"", string, - "\" cannot be used to get a FILE *", (char *) NULL); - return TCL_ERROR; -} - -/* - *---------------------------------------------------------------------- - * - * TclUnixWaitForFile -- - * - * This procedure waits synchronously for a file to become readable - * or writable, with an optional timeout. - * - * Results: - * The return value is an OR'ed combination of TCL_READABLE, - * TCL_WRITABLE, and TCL_EXCEPTION, indicating the conditions - * that are present on file at the time of the return. This - * procedure will not return until either "timeout" milliseconds - * have elapsed or at least one of the conditions given by mask - * has occurred for file (a return value of 0 means that a timeout - * occurred). No normal events will be serviced during the - * execution of this procedure. - * - * Side effects: - * Time passes. - * - *---------------------------------------------------------------------- - */ - -int -TclUnixWaitForFile(fd, mask, timeout) - int fd; /* Handle for file on which to wait. */ - int mask; /* What to wait for: OR'ed combination of - * TCL_READABLE, TCL_WRITABLE, and - * TCL_EXCEPTION. */ - int timeout; /* Maximum amount of time to wait for one - * of the conditions in mask to occur, in - * milliseconds. A value of 0 means don't - * wait at all, and a value of -1 means - * wait forever. */ -{ - Tcl_Time abortTime, now; - struct timeval blockTime, *timeoutPtr; - int index, bit, numFound, result = 0; - fd_mask readyMasks[3*MASK_SIZE]; - /* This array reflects the readable/writable - * conditions that were found to exist by the - * last call to select. */ - - /* - * If there is a non-zero finite timeout, compute the time when - * we give up. - */ - - if (timeout > 0) { - TclpGetTime(&now); - abortTime.sec = now.sec + timeout/1000; - abortTime.usec = now.usec + (timeout%1000)*1000; - if (abortTime.usec >= 1000000) { - abortTime.usec -= 1000000; - abortTime.sec += 1; - } - timeoutPtr = &blockTime; - } else if (timeout == 0) { - timeoutPtr = &blockTime; - blockTime.tv_sec = 0; - blockTime.tv_usec = 0; - } else { - timeoutPtr = NULL; - } - - /* - * Initialize the ready masks and compute the mask offsets. - */ - - if (fd >= FD_SETSIZE) { - panic("TclWaitForFile can't handle file id %d", fd); - } - memset((VOID *) readyMasks, 0, 3*MASK_SIZE*sizeof(fd_mask)); - index = fd/(NBBY*sizeof(fd_mask)); - bit = 1 << (fd%(NBBY*sizeof(fd_mask))); - - /* - * Loop in a mini-event loop of our own, waiting for either the - * file to become ready or a timeout to occur. - */ - - while (1) { - if (timeout > 0) { - blockTime.tv_sec = abortTime.sec - now.sec; - blockTime.tv_usec = abortTime.usec - now.usec; - if (blockTime.tv_usec < 0) { - blockTime.tv_sec -= 1; - blockTime.tv_usec += 1000000; - } - if (blockTime.tv_sec < 0) { - blockTime.tv_sec = 0; - blockTime.tv_usec = 0; - } - } - - /* - * Set the appropriate bit in the ready masks for the fd. - */ - - if (mask & TCL_READABLE) { - readyMasks[index] |= bit; - } - if (mask & TCL_WRITABLE) { - (readyMasks+MASK_SIZE)[index] |= bit; - } - if (mask & TCL_EXCEPTION) { - (readyMasks+2*(MASK_SIZE))[index] |= bit; - } - - /* - * Wait for the event or a timeout. - */ - - numFound = select(fd+1, (SELECT_MASK *) &readyMasks[0], - (SELECT_MASK *) &readyMasks[MASK_SIZE], - (SELECT_MASK *) &readyMasks[2*MASK_SIZE], timeoutPtr); - if (numFound == 1) { - if (readyMasks[index] & bit) { - result |= TCL_READABLE; - } - if ((readyMasks+MASK_SIZE)[index] & bit) { - result |= TCL_WRITABLE; - } - if ((readyMasks+2*(MASK_SIZE))[index] & bit) { - result |= TCL_EXCEPTION; - } - result &= mask; - if (result) { - break; - } - } - if (timeout == 0) { - break; - } - - /* - * The select returned early, so we need to recompute the timeout. - */ - - TclpGetTime(&now); - if ((abortTime.sec < now.sec) - || ((abortTime.sec == now.sec) - && (abortTime.usec <= now.usec))) { - break; - } - } - return result; -} diff --git a/unix/tclUnixEvent.c b/unix/tclUnixEvent.c deleted file mode 100644 index 00371b5..0000000 --- a/unix/tclUnixEvent.c +++ /dev/null @@ -1,76 +0,0 @@ -/* - * tclUnixEvent.c -- - * - * This file implements Unix specific event related routines. - * - * Copyright (c) 1997 by Sun Microsystems, Inc. - * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclUnixEvent.c,v 1.3 1999/04/16 00:48:04 stanton Exp $ - */ - -#include "tclInt.h" -#include "tclPort.h" - -/* - *---------------------------------------------------------------------- - * - * Tcl_Sleep -- - * - * Delay execution for the specified number of milliseconds. - * - * Results: - * None. - * - * Side effects: - * Time passes. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_Sleep(ms) - int ms; /* Number of milliseconds to sleep. */ -{ - struct timeval delay; - Tcl_Time before, after; - - /* - * The only trick here is that select appears to return early - * under some conditions, so we have to check to make sure that - * the right amount of time really has elapsed. If it's too - * early, go back to sleep again. - */ - - TclpGetTime(&before); - after = before; - after.sec += ms/1000; - after.usec += (ms%1000)*1000; - if (after.usec > 1000000) { - after.usec -= 1000000; - after.sec += 1; - } - while (1) { - delay.tv_sec = after.sec - before.sec; - delay.tv_usec = after.usec - before.usec; - if (delay.tv_usec < 0) { - delay.tv_usec += 1000000; - delay.tv_sec -= 1; - } - - /* - * Special note: must convert delay.tv_sec to int before comparing - * to zero, since delay.tv_usec is unsigned on some platforms. - */ - - if ((((int) delay.tv_sec) < 0) - || ((delay.tv_usec == 0) && (delay.tv_sec == 0))) { - break; - } - (void) select(0, (SELECT_MASK *) 0, (SELECT_MASK *) 0, - (SELECT_MASK *) 0, &delay); - TclpGetTime(&before); - } -} diff --git a/unix/tclUnixFCmd.c b/unix/tclUnixFCmd.c deleted file mode 100644 index 20998ca..0000000 --- a/unix/tclUnixFCmd.c +++ /dev/null @@ -1,1611 +0,0 @@ -/* - * tclUnixFCmd.c - * - * This file implements the unix specific portion of file manipulation - * subcommands of the "file" command. All filename arguments should - * already be translated to native format. - * - * Copyright (c) 1996-1998 Sun Microsystems, Inc. - * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclUnixFCmd.c,v 1.6 2000/04/04 08:05:57 hobbs Exp $ - * - * Portions of this code were derived from NetBSD source code which has - * the following copyright notice: - * - * Copyright (c) 1988, 1993, 1994 - * The Regents of the University of California. All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions - * are met: - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * 3. All advertising materials mentioning features or use of this software - * must display the following acknowledgement: - * This product includes software developed by the University of - * California, Berkeley and its contributors. - * 4. Neither the name of the University nor the names of its contributors - * may be used to endorse or promote products derived from this software - * without specific prior written permission. - * - * THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND - * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE - * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE - * ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE - * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS - * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) - * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF - * SUCH DAMAGE. - */ - -#include "tclInt.h" -#include "tclPort.h" -#include <utime.h> -#include <grp.h> -#ifndef HAVE_ST_BLKSIZE -#ifndef NO_FSTATFS -#include <sys/statfs.h> -#endif -#endif - -/* - * The following constants specify the type of callback when - * TraverseUnixTree() calls the traverseProc() - */ - -#define DOTREE_PRED 1 /* pre-order directory */ -#define DOTREE_POSTD 2 /* post-order directory */ -#define DOTREE_F 3 /* regular file */ - -/* - * Callbacks for file attributes code. - */ - -static int GetGroupAttribute _ANSI_ARGS_((Tcl_Interp *interp, - int objIndex, CONST char *fileName, - Tcl_Obj **attributePtrPtr)); -static int GetOwnerAttribute _ANSI_ARGS_((Tcl_Interp *interp, - int objIndex, CONST char *fileName, - Tcl_Obj **attributePtrPtr)); -static int GetPermissionsAttribute _ANSI_ARGS_(( - Tcl_Interp *interp, int objIndex, - CONST char *fileName, Tcl_Obj **attributePtrPtr)); -static int SetGroupAttribute _ANSI_ARGS_((Tcl_Interp *interp, - int objIndex, CONST char *fileName, - Tcl_Obj *attributePtr)); -static int SetOwnerAttribute _ANSI_ARGS_((Tcl_Interp *interp, - int objIndex, CONST char *fileName, - Tcl_Obj *attributePtr)); -static int SetPermissionsAttribute _ANSI_ARGS_(( - Tcl_Interp *interp, int objIndex, - CONST char *fileName, Tcl_Obj *attributePtr)); -static int GetModeFromPermString _ANSI_ARGS_(( - Tcl_Interp *interp, char *modeStringPtr, - mode_t *modePtr)); - -/* - * Prototype for the TraverseUnixTree callback function. - */ - -typedef int (TraversalProc) _ANSI_ARGS_((Tcl_DString *srcPtr, - Tcl_DString *dstPtr, CONST struct stat *statBufPtr, int type, - Tcl_DString *errorPtr)); - -/* - * Constants and variables necessary for file attributes subcommand. - */ - -enum { - UNIX_GROUP_ATTRIBUTE, - UNIX_OWNER_ATTRIBUTE, - UNIX_PERMISSIONS_ATTRIBUTE -}; - -char *tclpFileAttrStrings[] = { - "-group", - "-owner", - "-permissions", - (char *) NULL -}; - -CONST TclFileAttrProcs tclpFileAttrProcs[] = { - {GetGroupAttribute, SetGroupAttribute}, - {GetOwnerAttribute, SetOwnerAttribute}, - {GetPermissionsAttribute, SetPermissionsAttribute} -}; - -/* - * Declarations for local procedures defined in this file: - */ - -static int CopyFile _ANSI_ARGS_((CONST char *src, - CONST char *dst, CONST struct stat *statBufPtr)); -static int CopyFileAtts _ANSI_ARGS_((CONST char *src, - CONST char *dst, CONST struct stat *statBufPtr)); -static int DoCopyFile _ANSI_ARGS_((Tcl_DString *srcPtr, - Tcl_DString *dstPtr)); -static int DoCreateDirectory _ANSI_ARGS_((Tcl_DString *pathPtr)); -static int DoDeleteFile _ANSI_ARGS_((Tcl_DString *pathPtr)); -static int DoRemoveDirectory _ANSI_ARGS_((Tcl_DString *pathPtr, - int recursive, Tcl_DString *errorPtr)); -static int DoRenameFile _ANSI_ARGS_((CONST char *src, - CONST char *dst)); -static int TraversalCopy _ANSI_ARGS_((Tcl_DString *srcPtr, - Tcl_DString *dstPtr, CONST struct stat *statBufPtr, - int type, Tcl_DString *errorPtr)); -static int TraversalDelete _ANSI_ARGS_((Tcl_DString *srcPtr, - Tcl_DString *dstPtr, CONST struct stat *statBufPtr, - int type, Tcl_DString *errorPtr)); -static int TraverseUnixTree _ANSI_ARGS_(( - TraversalProc *traversalProc, - Tcl_DString *sourcePtr, Tcl_DString *destPtr, - Tcl_DString *errorPtr)); - -/* - *--------------------------------------------------------------------------- - * - * TclpRenameFile, DoRenameFile -- - * - * Changes the name of an existing file or directory, from src to dst. - * If src and dst refer to the same file or directory, does nothing - * and returns success. Otherwise if dst already exists, it will be - * deleted and replaced by src subject to the following conditions: - * If src is a directory, dst may be an empty directory. - * If src is a file, dst may be a file. - * In any other situation where dst already exists, the rename will - * fail. - * - * Results: - * If the directory was successfully created, returns TCL_OK. - * Otherwise the return value is TCL_ERROR and errno is set to - * indicate the error. Some possible values for errno are: - * - * EACCES: src or dst parent directory can't be read and/or written. - * EEXIST: dst is a non-empty directory. - * EINVAL: src is a root directory or dst is a subdirectory of src. - * EISDIR: dst is a directory, but src is not. - * ENOENT: src doesn't exist, or src or dst is "". - * ENOTDIR: src is a directory, but dst is not. - * EXDEV: src and dst are on different filesystems. - * - * Side effects: - * The implementation of rename may allow cross-filesystem renames, - * but the caller should be prepared to emulate it with copy and - * delete if errno is EXDEV. - * - *--------------------------------------------------------------------------- - */ - -int -TclpRenameFile(src, dst) - CONST char *src; /* Pathname of file or dir to be renamed - * (UTF-8). */ - CONST char *dst; /* New pathname of file or directory - * (UTF-8). */ -{ - int result; - Tcl_DString srcString, dstString; - - Tcl_UtfToExternalDString(NULL, src, -1, &srcString); - Tcl_UtfToExternalDString(NULL, dst, -1, &dstString); - result = DoRenameFile(Tcl_DStringValue(&srcString), - Tcl_DStringValue(&dstString)); - Tcl_DStringFree(&srcString); - Tcl_DStringFree(&dstString); - return result; -} - -static int -DoRenameFile(src, dst) - CONST char *src; /* Pathname of file or dir to be renamed - * (native). */ - CONST char *dst; /* New pathname of file or directory - * (native). */ -{ - if (rename(src, dst) == 0) { /* INTL: Native. */ - return TCL_OK; - } - if (errno == ENOTEMPTY) { - errno = EEXIST; - } - - /* - * IRIX returns EIO when you attept to move a directory into - * itself. We just map EIO to EINVAL get the right message on SGI. - * Most platforms don't return EIO except in really strange cases. - */ - - if (errno == EIO) { - errno = EINVAL; - } - -#ifndef NO_REALPATH - /* - * SunOS 4.1.4 reports overwriting a non-empty directory with a - * directory as EINVAL instead of EEXIST (first rule out the correct - * EINVAL result code for moving a directory into itself). Must be - * conditionally compiled because realpath() not defined on all systems. - */ - - if (errno == EINVAL) { - char srcPath[MAXPATHLEN], dstPath[MAXPATHLEN]; - DIR *dirPtr; - struct dirent *dirEntPtr; - - if ((realpath((char *) src, srcPath) != NULL) /* INTL: Native. */ - && (realpath((char *) dst, dstPath) != NULL) /* INTL: Native. */ - && (strncmp(srcPath, dstPath, strlen(srcPath)) != 0)) { - dirPtr = opendir(dst); /* INTL: Native. */ - if (dirPtr != NULL) { - while (1) { - dirEntPtr = readdir(dirPtr); /* INTL: Native. */ - if (dirEntPtr == NULL) { - break; - } - if ((strcmp(dirEntPtr->d_name, ".") != 0) && - (strcmp(dirEntPtr->d_name, "..") != 0)) { - errno = EEXIST; - closedir(dirPtr); - return TCL_ERROR; - } - } - closedir(dirPtr); - } - } - errno = EINVAL; - } -#endif /* !NO_REALPATH */ - - if (strcmp(src, "/") == 0) { - /* - * Alpha reports renaming / as EBUSY and Linux reports it as EACCES, - * instead of EINVAL. - */ - - errno = EINVAL; - } - - /* - * DEC Alpha OSF1 V3.0 returns EACCES when attempting to move a - * file across filesystems and the parent directory of that file is - * not writable. Most other systems return EXDEV. Does nothing to - * correct this behavior. - */ - - return TCL_ERROR; -} - - -/* - *--------------------------------------------------------------------------- - * - * TclpCopyFile, DoCopyFile -- - * - * Copy a single file (not a directory). If dst already exists and - * is not a directory, it is removed. - * - * Results: - * If the file was successfully copied, returns TCL_OK. Otherwise - * the return value is TCL_ERROR and errno is set to indicate the - * error. Some possible values for errno are: - * - * EACCES: src or dst parent directory can't be read and/or written. - * EISDIR: src or dst is a directory. - * ENOENT: src doesn't exist. src or dst is "". - * - * Side effects: - * This procedure will also copy symbolic links, block, and - * character devices, and fifos. For symbolic links, the links - * themselves will be copied and not what they point to. For the - * other special file types, the directory entry will be copied and - * not the contents of the device that it refers to. - * - *--------------------------------------------------------------------------- - */ - -int -TclpCopyFile(src, dst) - CONST char *src; /* Pathname of file to be copied (UTF-8). */ - CONST char *dst; /* Pathname of file to copy to (UTF-8). */ -{ - int result; - Tcl_DString srcString, dstString; - - Tcl_UtfToExternalDString(NULL, src, -1, &srcString); - Tcl_UtfToExternalDString(NULL, dst, -1, &dstString); - result = DoCopyFile(&srcString, &dstString); - Tcl_DStringFree(&srcString); - Tcl_DStringFree(&dstString); - return result; -} - -static int -DoCopyFile(srcPtr, dstPtr) - Tcl_DString *srcPtr; /* Pathname of file to be copied (native). */ - Tcl_DString *dstPtr; /* Pathname of file to copy to (native). */ -{ - struct stat srcStatBuf, dstStatBuf; - CONST char *src, *dst; - - src = Tcl_DStringValue(srcPtr); - dst = Tcl_DStringValue(dstPtr); - - /* - * Have to do a stat() to determine the filetype. - */ - - if (lstat(src, &srcStatBuf) != 0) { /* INTL: Native. */ - return TCL_ERROR; - } - if (S_ISDIR(srcStatBuf.st_mode)) { - errno = EISDIR; - return TCL_ERROR; - } - - /* - * symlink, and some of the other calls will fail if the target - * exists, so we remove it first - */ - - if (lstat(dst, &dstStatBuf) == 0) { /* INTL: Native. */ - if (S_ISDIR(dstStatBuf.st_mode)) { - errno = EISDIR; - return TCL_ERROR; - } - } - if (unlink(dst) != 0) { /* INTL: Native. */ - if (errno != ENOENT) { - return TCL_ERROR; - } - } - - switch ((int) (srcStatBuf.st_mode & S_IFMT)) { - case S_IFLNK: { - char link[MAXPATHLEN]; - int length; - - length = readlink(src, link, sizeof(link)); /* INTL: Native. */ - if (length == -1) { - return TCL_ERROR; - } - link[length] = '\0'; - if (symlink(link, dst) < 0) { /* INTL: Native. */ - return TCL_ERROR; - } - break; - } - case S_IFBLK: - case S_IFCHR: { - if (mknod(dst, srcStatBuf.st_mode, /* INTL: Native. */ - srcStatBuf.st_rdev) < 0) { - return TCL_ERROR; - } - return CopyFileAtts(src, dst, &srcStatBuf); - } - case S_IFIFO: { - if (mkfifo(dst, srcStatBuf.st_mode) < 0) { /* INTL: Native. */ - return TCL_ERROR; - } - return CopyFileAtts(src, dst, &srcStatBuf); - } - default: { - return CopyFile(src, dst, &srcStatBuf); - } - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * CopyFile - - * - * Helper function for TclpCopyFile. Copies one regular file, - * using read() and write(). - * - * Results: - * A standard Tcl result. - * - * Side effects: - * A file is copied. Dst will be overwritten if it exists. - * - *---------------------------------------------------------------------- - */ - -static int -CopyFile(src, dst, statBufPtr) - CONST char *src; /* Pathname of file to copy (native). */ - CONST char *dst; /* Pathname of file to create/overwrite - * (native). */ - CONST struct stat *statBufPtr; - /* Used to determine mode and blocksize. */ -{ - int srcFd; - int dstFd; - u_int blockSize; /* Optimal I/O blocksize for filesystem */ - char *buffer; /* Data buffer for copy */ - size_t nread; - - if ((srcFd = open(src, O_RDONLY, 0)) < 0) { /* INTL: Native. */ - return TCL_ERROR; - } - - dstFd = open(dst, O_CREAT | O_TRUNC | O_WRONLY, /* INTL: Native. */ - statBufPtr->st_mode); - if (dstFd < 0) { - close(srcFd); - return TCL_ERROR; - } - -#ifdef HAVE_ST_BLKSIZE - blockSize = statBufPtr->st_blksize; -#else -#ifndef NO_FSTATFS - { - struct statfs fs; - if (fstatfs(srcFd, &fs, sizeof(fs), 0) == 0) { - blockSize = fs.f_bsize; - } else { - blockSize = 4096; - } - } -#else - blockSize = 4096; -#endif -#endif - - buffer = ckalloc(blockSize); - while (1) { - nread = read(srcFd, buffer, blockSize); - if ((nread == -1) || (nread == 0)) { - break; - } - if (write(dstFd, buffer, nread) != nread) { - nread = (size_t) -1; - break; - } - } - - ckfree(buffer); - close(srcFd); - if ((close(dstFd) != 0) || (nread == -1)) { - unlink(dst); /* INTL: Native. */ - return TCL_ERROR; - } - if (CopyFileAtts(src, dst, statBufPtr) == TCL_ERROR) { - /* - * The copy succeeded, but setting the permissions failed, so be in - * a consistent state, we remove the file that was created by the - * copy. - */ - - unlink(dst); /* INTL: Native. */ - return TCL_ERROR; - } - return TCL_OK; -} - -/* - *--------------------------------------------------------------------------- - * - * TclpDeleteFile, DoDeleteFile -- - * - * Removes a single file (not a directory). - * - * Results: - * If the file was successfully deleted, returns TCL_OK. Otherwise - * the return value is TCL_ERROR and errno is set to indicate the - * error. Some possible values for errno are: - * - * EACCES: a parent directory can't be read and/or written. - * EISDIR: path is a directory. - * ENOENT: path doesn't exist or is "". - * - * Side effects: - * The file is deleted, even if it is read-only. - * - *--------------------------------------------------------------------------- - */ - -int -TclpDeleteFile(path) - CONST char *path; /* Pathname of file to be removed (UTF-8). */ -{ - int result; - Tcl_DString pathString; - - Tcl_UtfToExternalDString(NULL, path, -1, &pathString); - result = DoDeleteFile(&pathString); - Tcl_DStringFree(&pathString); - return result; -} - -static int -DoDeleteFile(pathPtr) - Tcl_DString *pathPtr; /* Pathname of file to be removed (native). */ -{ - CONST char *path; - - path = Tcl_DStringValue(pathPtr); - if (unlink(path) != 0) { /* INTL: Native. */ - return TCL_ERROR; - } - return TCL_OK; -} - -/* - *--------------------------------------------------------------------------- - * - * TclpCreateDirectory, DoCreateDirectory -- - * - * Creates the specified directory. All parent directories of the - * specified directory must already exist. The directory is - * automatically created with permissions so that user can access - * the new directory and create new files or subdirectories in it. - * - * Results: - * If the directory was successfully created, returns TCL_OK. - * Otherwise the return value is TCL_ERROR and errno is set to - * indicate the error. Some possible values for errno are: - * - * EACCES: a parent directory can't be read and/or written. - * EEXIST: path already exists. - * ENOENT: a parent directory doesn't exist. - * - * Side effects: - * A directory is created with the current umask, except that - * permission for u+rwx will always be added. - * - *--------------------------------------------------------------------------- - */ - -int -TclpCreateDirectory(path) - CONST char *path; /* Pathname of directory to create (UTF-8). */ -{ - int result; - Tcl_DString pathString; - - Tcl_UtfToExternalDString(NULL, path, -1, &pathString); - result = DoCreateDirectory(&pathString); - Tcl_DStringFree(&pathString); - return result; -} - -static int -DoCreateDirectory(pathPtr) - Tcl_DString *pathPtr; /* Pathname of directory to create (native). */ -{ - mode_t mode; - CONST char *path; - - path = Tcl_DStringValue(pathPtr); - - mode = umask(0); - umask(mode); - - /* - * umask return value is actually the inverse of the permissions. - */ - - mode = (0777 & ~mode) | S_IRUSR | S_IWUSR | S_IXUSR; - - if (mkdir(path, mode) != 0) { /* INTL: Native. */ - return TCL_ERROR; - } - return TCL_OK; -} - -/* - *--------------------------------------------------------------------------- - * - * TclpCopyDirectory -- - * - * Recursively copies a directory. The target directory dst must - * not already exist. Note that this function does not merge two - * directory hierarchies, even if the target directory is an an - * empty directory. - * - * Results: - * If the directory was successfully copied, returns TCL_OK. - * Otherwise the return value is TCL_ERROR, errno is set to indicate - * the error, and the pathname of the file that caused the error - * is stored in errorPtr. See TclpCreateDirectory and TclpCopyFile - * for a description of possible values for errno. - * - * Side effects: - * An exact copy of the directory hierarchy src will be created - * with the name dst. If an error occurs, the error will - * be returned immediately, and remaining files will not be - * processed. - * - *--------------------------------------------------------------------------- - */ - -int -TclpCopyDirectory(src, dst, errorPtr) - CONST char *src; /* Pathname of directory to be copied - * (UTF-8). */ - CONST char *dst; /* Pathname of target directory (UTF-8). */ - Tcl_DString *errorPtr; /* If non-NULL, uninitialized or free - * DString filled with UTF-8 name of file - * causing error. */ -{ - Tcl_DString srcString, dstString; - int result; - - Tcl_UtfToExternalDString(NULL, src, -1, &srcString); - Tcl_UtfToExternalDString(NULL, dst, -1, &dstString); - - result = TraverseUnixTree(TraversalCopy, &srcString, &dstString, errorPtr); - - Tcl_DStringFree(&srcString); - Tcl_DStringFree(&dstString); - return result; -} - -/* - *--------------------------------------------------------------------------- - * - * TclpRemoveDirectory, DoRemoveDirectory -- - * - * Removes directory (and its contents, if the recursive flag is set). - * - * Results: - * If the directory was successfully removed, returns TCL_OK. - * Otherwise the return value is TCL_ERROR, errno is set to indicate - * the error, and the pathname of the file that caused the error - * is stored in errorPtr. Some possible values for errno are: - * - * EACCES: path directory can't be read and/or written. - * EEXIST: path is a non-empty directory. - * EINVAL: path is a root directory. - * ENOENT: path doesn't exist or is "". - * ENOTDIR: path is not a directory. - * - * Side effects: - * Directory removed. If an error occurs, the error will be returned - * immediately, and remaining files will not be deleted. - * - *--------------------------------------------------------------------------- - */ - -int -TclpRemoveDirectory(path, recursive, errorPtr) - CONST char *path; /* Pathname of directory to be removed - * (UTF-8). */ - int recursive; /* If non-zero, removes directories that - * are nonempty. Otherwise, will only remove - * empty directories. */ - Tcl_DString *errorPtr; /* If non-NULL, uninitialized or free - * DString filled with UTF-8 name of file - * causing error. */ -{ - int result; - Tcl_DString pathString; - - Tcl_UtfToExternalDString(NULL, path, -1, &pathString); - result = DoRemoveDirectory(&pathString, recursive, errorPtr); - Tcl_DStringFree(&pathString); - - return result; -} - -static int -DoRemoveDirectory(pathPtr, recursive, errorPtr) - Tcl_DString *pathPtr; /* Pathname of directory to be removed - * (native). */ - int recursive; /* If non-zero, removes directories that - * are nonempty. Otherwise, will only remove - * empty directories. */ - Tcl_DString *errorPtr; /* If non-NULL, uninitialized or free - * DString filled with UTF-8 name of file - * causing error. */ -{ - CONST char *path; - - path = Tcl_DStringValue(pathPtr); - if (rmdir(path) == 0) { /* INTL: Native. */ - return TCL_OK; - } - if (errno == ENOTEMPTY) { - errno = EEXIST; - } - if ((errno != EEXIST) || (recursive == 0)) { - if (errorPtr != NULL) { - Tcl_ExternalToUtfDString(NULL, path, -1, errorPtr); - } - return TCL_ERROR; - } - - /* - * The directory is nonempty, but the recursive flag has been - * specified, so we recursively remove all the files in the directory. - */ - - return TraverseUnixTree(TraversalDelete, pathPtr, NULL, errorPtr); -} - -/* - *--------------------------------------------------------------------------- - * - * TraverseUnixTree -- - * - * Traverse directory tree specified by sourcePtr, calling the function - * traverseProc for each file and directory encountered. If destPtr - * is non-null, each of name in the sourcePtr directory is appended to - * the directory specified by destPtr and passed as the second argument - * to traverseProc() . - * - * Results: - * Standard Tcl result. - * - * Side effects: - * None caused by TraverseUnixTree, however the user specified - * traverseProc() may change state. If an error occurs, the error will - * be returned immediately, and remaining files will not be processed. - * - *--------------------------------------------------------------------------- - */ - -static int -TraverseUnixTree(traverseProc, sourcePtr, targetPtr, errorPtr) - TraversalProc *traverseProc;/* Function to call for every file and - * directory in source hierarchy. */ - Tcl_DString *sourcePtr; /* Pathname of source directory to be - * traversed (native). */ - Tcl_DString *targetPtr; /* Pathname of directory to traverse in - * parallel with source directory (native). */ - Tcl_DString *errorPtr; /* If non-NULL, uninitialized or free - * DString filled with UTF-8 name of file - * causing error. */ -{ - struct stat statBuf; - CONST char *source, *errfile; - int result, sourceLen; - int targetLen; - struct dirent *dirEntPtr; - DIR *dirPtr; - - errfile = NULL; - result = TCL_OK; - targetLen = 0; /* lint. */ - - source = Tcl_DStringValue(sourcePtr); - if (lstat(source, &statBuf) != 0) { /* INTL: Native. */ - errfile = source; - goto end; - } - if (!S_ISDIR(statBuf.st_mode)) { - /* - * Process the regular file - */ - - return (*traverseProc)(sourcePtr, targetPtr, &statBuf, DOTREE_F, - errorPtr); - } - dirPtr = opendir(source); /* INTL: Native. */ - if (dirPtr == NULL) { - /* - * Can't read directory - */ - - errfile = source; - goto end; - } - result = (*traverseProc)(sourcePtr, targetPtr, &statBuf, DOTREE_PRED, - errorPtr); - if (result != TCL_OK) { - closedir(dirPtr); - return result; - } - - Tcl_DStringAppend(sourcePtr, "/", 1); - sourceLen = Tcl_DStringLength(sourcePtr); - - if (targetPtr != NULL) { - Tcl_DStringAppend(targetPtr, "/", 1); - targetLen = Tcl_DStringLength(targetPtr); - } - - while ((dirEntPtr = readdir(dirPtr)) != NULL) { /* INTL: Native. */ - if ((strcmp(dirEntPtr->d_name, ".") == 0) - || (strcmp(dirEntPtr->d_name, "..") == 0)) { - continue; - } - - /* - * Append name after slash, and recurse on the file. - */ - - Tcl_DStringAppend(sourcePtr, dirEntPtr->d_name, -1); - if (targetPtr != NULL) { - Tcl_DStringAppend(targetPtr, dirEntPtr->d_name, -1); - } - result = TraverseUnixTree(traverseProc, sourcePtr, targetPtr, - errorPtr); - if (result != TCL_OK) { - break; - } - - /* - * Remove name after slash. - */ - - Tcl_DStringSetLength(sourcePtr, sourceLen); - if (targetPtr != NULL) { - Tcl_DStringSetLength(targetPtr, targetLen); - } - } - closedir(dirPtr); - - /* - * Strip off the trailing slash we added - */ - - Tcl_DStringSetLength(sourcePtr, sourceLen - 1); - if (targetPtr != NULL) { - Tcl_DStringSetLength(targetPtr, targetLen - 1); - } - - if (result == TCL_OK) { - /* - * Call traverseProc() on a directory after visiting all the - * files in that directory. - */ - - result = (*traverseProc)(sourcePtr, targetPtr, &statBuf, DOTREE_POSTD, - errorPtr); - } - end: - if (errfile != NULL) { - if (errorPtr != NULL) { - Tcl_ExternalToUtfDString(NULL, errfile, -1, errorPtr); - } - result = TCL_ERROR; - } - - return result; -} - -/* - *---------------------------------------------------------------------- - * - * TraversalCopy - * - * Called from TraverseUnixTree in order to execute a recursive copy of a - * directory. - * - * Results: - * Standard Tcl result. - * - * Side effects: - * The file or directory src may be copied to dst, depending on - * the value of type. - * - *---------------------------------------------------------------------- - */ - -static int -TraversalCopy(srcPtr, dstPtr, statBufPtr, type, errorPtr) - Tcl_DString *srcPtr; /* Source pathname to copy (native). */ - Tcl_DString *dstPtr; /* Destination pathname of copy (native). */ - CONST struct stat *statBufPtr; - /* Stat info for file specified by srcPtr. */ - int type; /* Reason for call - see TraverseUnixTree(). */ - Tcl_DString *errorPtr; /* If non-NULL, uninitialized or free - * DString filled with UTF-8 name of file - * causing error. */ -{ - switch (type) { - case DOTREE_F: - if (DoCopyFile(srcPtr, dstPtr) == TCL_OK) { - return TCL_OK; - } - break; - - case DOTREE_PRED: - if (DoCreateDirectory(dstPtr) == TCL_OK) { - return TCL_OK; - } - break; - - case DOTREE_POSTD: - if (CopyFileAtts(Tcl_DStringValue(srcPtr), - Tcl_DStringValue(dstPtr), statBufPtr) == TCL_OK) { - return TCL_OK; - } - break; - - } - - /* - * There shouldn't be a problem with src, because we already checked it - * to get here. - */ - - if (errorPtr != NULL) { - Tcl_ExternalToUtfDString(NULL, Tcl_DStringValue(dstPtr), - Tcl_DStringLength(dstPtr), errorPtr); - } - return TCL_ERROR; -} - -/* - *--------------------------------------------------------------------------- - * - * TraversalDelete -- - * - * Called by procedure TraverseUnixTree for every file and directory - * that it encounters in a directory hierarchy. This procedure unlinks - * files, and removes directories after all the containing files - * have been processed. - * - * Results: - * Standard Tcl result. - * - * Side effects: - * Files or directory specified by src will be deleted. - * - *---------------------------------------------------------------------- - */ - -static int -TraversalDelete(srcPtr, ignore, statBufPtr, type, errorPtr) - Tcl_DString *srcPtr; /* Source pathname (native). */ - Tcl_DString *ignore; /* Destination pathname (not used). */ - CONST struct stat *statBufPtr; - /* Stat info for file specified by srcPtr. */ - int type; /* Reason for call - see TraverseUnixTree(). */ - Tcl_DString *errorPtr; /* If non-NULL, uninitialized or free - * DString filled with UTF-8 name of file - * causing error. */ -{ - switch (type) { - case DOTREE_F: { - if (DoDeleteFile(srcPtr) == 0) { - return TCL_OK; - } - break; - } - case DOTREE_PRED: { - return TCL_OK; - } - case DOTREE_POSTD: { - if (DoRemoveDirectory(srcPtr, 0, NULL) == 0) { - return TCL_OK; - } - break; - } - } - if (errorPtr != NULL) { - Tcl_ExternalToUtfDString(NULL, Tcl_DStringValue(srcPtr), - Tcl_DStringLength(srcPtr), errorPtr); - } - return TCL_ERROR; -} - -/* - *--------------------------------------------------------------------------- - * - * CopyFileAtts -- - * - * Copy the file attributes such as owner, group, permissions, - * and modification date from one file to another. - * - * Results: - * Standard Tcl result. - * - * Side effects: - * user id, group id, permission bits, last modification time, and - * last access time are updated in the new file to reflect the - * old file. - * - *--------------------------------------------------------------------------- - */ - -static int -CopyFileAtts(src, dst, statBufPtr) - CONST char *src; /* Path name of source file (native). */ - CONST char *dst; /* Path name of target file (native). */ - CONST struct stat *statBufPtr; - /* Stat info for source file */ -{ - struct utimbuf tval; - mode_t newMode; - - newMode = statBufPtr->st_mode - & (S_ISUID | S_ISGID | S_IRWXU | S_IRWXG | S_IRWXO); - - /* - * Note that if you copy a setuid file that is owned by someone - * else, and you are not root, then the copy will be setuid to you. - * The most correct implementation would probably be to have the - * copy not setuid to anyone if the original file was owned by - * someone else, but this corner case isn't currently handled. - * It would require another lstat(), or getuid(). - */ - - if (chmod(dst, newMode)) { /* INTL: Native. */ - newMode &= ~(S_ISUID | S_ISGID); - if (chmod(dst, newMode)) { /* INTL: Native. */ - return TCL_ERROR; - } - } - - tval.actime = statBufPtr->st_atime; - tval.modtime = statBufPtr->st_mtime; - - if (utime(dst, &tval)) { /* INTL: Native. */ - return TCL_ERROR; - } - return TCL_OK; -} - - -/* - *---------------------------------------------------------------------- - * - * GetGroupAttribute - * - * Gets the group attribute of a file. - * - * Results: - * Standard TCL result. Returns a new Tcl_Obj in attributePtrPtr - * if there is no error. - * - * Side effects: - * A new object is allocated. - * - *---------------------------------------------------------------------- - */ - -static int -GetGroupAttribute(interp, objIndex, fileName, attributePtrPtr) - Tcl_Interp *interp; /* The interp we are using for errors. */ - int objIndex; /* The index of the attribute. */ - CONST char *fileName; /* The name of the file (UTF-8). */ - Tcl_Obj **attributePtrPtr; /* A pointer to return the object with. */ -{ - struct stat statBuf; - struct group *groupPtr; - int result; - - result = TclStat(fileName, &statBuf); - - if (result != 0) { - Tcl_AppendResult(interp, "could not read \"", fileName, "\": ", - Tcl_PosixError(interp), (char *) NULL); - return TCL_ERROR; - } - - groupPtr = getgrgid(statBuf.st_gid); /* INTL: Native. */ - if (groupPtr == NULL) { - *attributePtrPtr = Tcl_NewIntObj(statBuf.st_gid); - } else { - Tcl_DString ds; - CONST char *utf; - - utf = Tcl_ExternalToUtfDString(NULL, groupPtr->gr_name, -1, &ds); - *attributePtrPtr = Tcl_NewStringObj(utf, -1); - Tcl_DStringFree(&ds); - } - endgrent(); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * GetOwnerAttribute - * - * Gets the owner attribute of a file. - * - * Results: - * Standard TCL result. Returns a new Tcl_Obj in attributePtrPtr - * if there is no error. - * - * Side effects: - * A new object is allocated. - * - *---------------------------------------------------------------------- - */ - -static int -GetOwnerAttribute(interp, objIndex, fileName, attributePtrPtr) - Tcl_Interp *interp; /* The interp we are using for errors. */ - int objIndex; /* The index of the attribute. */ - CONST char *fileName; /* The name of the file (UTF-8). */ - Tcl_Obj **attributePtrPtr; /* A pointer to return the object with. */ -{ - struct stat statBuf; - struct passwd *pwPtr; - int result; - - result = TclStat(fileName, &statBuf); - - if (result != 0) { - Tcl_AppendResult(interp, "could not read \"", fileName, "\": ", - Tcl_PosixError(interp), (char *) NULL); - return TCL_ERROR; - } - - pwPtr = getpwuid(statBuf.st_uid); /* INTL: Native. */ - if (pwPtr == NULL) { - *attributePtrPtr = Tcl_NewIntObj(statBuf.st_uid); - } else { - Tcl_DString ds; - CONST char *utf; - - utf = Tcl_ExternalToUtfDString(NULL, pwPtr->pw_name, -1, &ds); - *attributePtrPtr = Tcl_NewStringObj(utf, Tcl_DStringLength(&ds)); - Tcl_DStringFree(&ds); - } - endpwent(); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * GetPermissionsAttribute - * - * Gets the group attribute of a file. - * - * Results: - * Standard TCL result. Returns a new Tcl_Obj in attributePtrPtr - * if there is no error. The object will have ref count 0. - * - * Side effects: - * A new object is allocated. - * - *---------------------------------------------------------------------- - */ - -static int -GetPermissionsAttribute(interp, objIndex, fileName, attributePtrPtr) - Tcl_Interp *interp; /* The interp we are using for errors. */ - int objIndex; /* The index of the attribute. */ - CONST char *fileName; /* The name of the file (UTF-8). */ - Tcl_Obj **attributePtrPtr; /* A pointer to return the object with. */ -{ - struct stat statBuf; - char returnString[7]; - int result; - - result = TclStat(fileName, &statBuf); - - if (result != 0) { - Tcl_AppendResult(interp, "could not read \"", fileName, "\": ", - Tcl_PosixError(interp), (char *) NULL); - return TCL_ERROR; - } - - sprintf(returnString, "%0#5lo", (statBuf.st_mode & 0x00007FFF)); - - *attributePtrPtr = Tcl_NewStringObj(returnString, -1); - - return TCL_OK; -} - -/* - *--------------------------------------------------------------------------- - * - * SetGroupAttribute -- - * - * Sets the group of the file to the specified group. - * - * Results: - * Standard TCL result. - * - * Side effects: - * As above. - * - *--------------------------------------------------------------------------- - */ - -static int -SetGroupAttribute(interp, objIndex, fileName, attributePtr) - Tcl_Interp *interp; /* The interp for error reporting. */ - int objIndex; /* The index of the attribute. */ - CONST char *fileName; /* The name of the file (UTF-8). */ - Tcl_Obj *attributePtr; /* New group for file. */ -{ - long gid; - int result; - Tcl_DString ds; - CONST char *native; - - if (Tcl_GetLongFromObj(NULL, attributePtr, &gid) != TCL_OK) { - struct group *groupPtr; - CONST char *string; - int length; - - string = Tcl_GetStringFromObj(attributePtr, &length); - - native = Tcl_UtfToExternalDString(NULL, string, length, &ds); - groupPtr = getgrnam(native); /* INTL: Native. */ - Tcl_DStringFree(&ds); - - if (groupPtr == NULL) { - endgrent(); - Tcl_AppendResult(interp, "could not set group for file \"", - fileName, "\": group \"", string, "\" does not exist", - (char *) NULL); - return TCL_ERROR; - } - gid = groupPtr->gr_gid; - } - - native = Tcl_UtfToExternalDString(NULL, fileName, -1, &ds); - result = chown(native, (uid_t) -1, (gid_t) gid); /* INTL: Native. */ - Tcl_DStringFree(&ds); - - endgrent(); - if (result != 0) { - Tcl_AppendResult(interp, "could not set group for file \"", - fileName, "\": ", Tcl_PosixError(interp), (char *) NULL); - return TCL_ERROR; - } - return TCL_OK; -} - -/* - *--------------------------------------------------------------------------- - * - * SetOwnerAttribute -- - * - * Sets the owner of the file to the specified owner. - * - * Results: - * Standard TCL result. - * - * Side effects: - * As above. - * - *--------------------------------------------------------------------------- - */ - -static int -SetOwnerAttribute(interp, objIndex, fileName, attributePtr) - Tcl_Interp *interp; /* The interp for error reporting. */ - int objIndex; /* The index of the attribute. */ - CONST char *fileName; /* The name of the file (UTF-8). */ - Tcl_Obj *attributePtr; /* New owner for file. */ -{ - long uid; - int result; - Tcl_DString ds; - CONST char *native; - - if (Tcl_GetLongFromObj(NULL, attributePtr, &uid) != TCL_OK) { - struct passwd *pwPtr; - CONST char *string; - int length; - - string = Tcl_GetStringFromObj(attributePtr, &length); - - native = Tcl_UtfToExternalDString(NULL, string, length, &ds); - pwPtr = getpwnam(native); /* INTL: Native. */ - Tcl_DStringFree(&ds); - - if (pwPtr == NULL) { - Tcl_AppendResult(interp, "could not set owner for file \"", - fileName, "\": user \"", string, "\" does not exist", - (char *) NULL); - return TCL_ERROR; - } - uid = pwPtr->pw_uid; - } - - native = Tcl_UtfToExternalDString(NULL, fileName, -1, &ds); - result = chown(native, (uid_t) uid, (gid_t) -1); /* INTL: Native. */ - Tcl_DStringFree(&ds); - - if (result != 0) { - Tcl_AppendResult(interp, "could not set owner for file \"", fileName, - "\": ", Tcl_PosixError(interp), (char *) NULL); - return TCL_ERROR; - } - return TCL_OK; -} - -/* - *--------------------------------------------------------------------------- - * - * SetPermissionsAttribute - * - * Sets the file to the given permission. - * - * Results: - * Standard TCL result. - * - * Side effects: - * The permission of the file is changed. - * - *--------------------------------------------------------------------------- - */ - -static int -SetPermissionsAttribute(interp, objIndex, fileName, attributePtr) - Tcl_Interp *interp; /* The interp we are using for errors. */ - int objIndex; /* The index of the attribute. */ - CONST char *fileName; /* The name of the file (UTF-8). */ - Tcl_Obj *attributePtr; /* The attribute to set. */ -{ - long mode; - mode_t newMode; - int result; - CONST char *native; - Tcl_DString ds; - - /* - * First try if the string is a number - */ - if (Tcl_GetLongFromObj(NULL, attributePtr, &mode) == TCL_OK) { - newMode = (mode_t) (mode & 0x00007FFF); - } else { - struct stat buf; - char *modeStringPtr = Tcl_GetString(attributePtr); - - /* - * Try the forms "rwxrwxrwx" and "ugo=rwx" - * - * We get the current mode of the file, in order to allow for - * ug+-=rwx style chmod strings. - */ - result = TclStat(fileName, &buf); - if (result != 0) { - Tcl_AppendResult(interp, "could not read \"", fileName, "\": ", - Tcl_PosixError(interp), (char *) NULL); - return TCL_ERROR; - } - newMode = (mode_t) (buf.st_mode & 0x00007FFF); - - if (GetModeFromPermString(NULL, modeStringPtr, &newMode) != TCL_OK) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "unknown permission string format \"", - modeStringPtr, "\"", (char *) NULL); - return TCL_ERROR; - } - } - - native = Tcl_UtfToExternalDString(NULL, fileName, -1, &ds); - result = chmod(native, newMode); /* INTL: Native. */ - Tcl_DStringFree(&ds); - if (result != 0) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "could not set permissions for file \"", fileName, "\": ", - Tcl_PosixError(interp), (char *) NULL); - return TCL_ERROR; - } - return TCL_OK; -} - -/* - *--------------------------------------------------------------------------- - * - * TclpListVolumes -- - * - * Lists the currently mounted volumes, which on UNIX is just /. - * - * Results: - * A standard Tcl result. Will always be TCL_OK, since there is no way - * that this command can fail. Also, the interpreter's result is set to - * the list of volumes. - * - * Side effects: - * None. - * - *--------------------------------------------------------------------------- - */ - -int -TclpListVolumes(interp) - Tcl_Interp *interp; /* Interpreter to which to pass - * the volume list. */ -{ - Tcl_Obj *resultPtr; - - resultPtr = Tcl_GetObjResult(interp); - Tcl_SetStringObj(resultPtr, "/", 1); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * GetModeFromPermString -- - * - * This procedure is invoked to process the "file permissions" - * Tcl command, to check for a "rwxrwxrwx" or "ugoa+-=rwxst" string. - * See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - -static int -GetModeFromPermString(interp, modeStringPtr, modePtr) - Tcl_Interp *interp; /* The interp we are using for errors. */ - char *modeStringPtr; /* Permissions string */ - mode_t *modePtr; /* pointer to the mode value */ -{ - mode_t newMode; - mode_t oldMode; /* Storage for the value of the old mode - * (that is passed in), to allow for the - * chmod style manipulation */ - int i,n, who, op, what, op_found, who_found; - - /* - * We start off checking for an "rwxrwxrwx" style permissions string - */ - if (strlen(modeStringPtr) != 9) { - goto chmodStyleCheck; - } - - newMode = 0; - for (i = 0; i < 9; i++) { - switch (*(modeStringPtr+i)) { - case 'r': - if ((i%3) != 0) { - goto chmodStyleCheck; - } - newMode |= (1<<(8-i)); - break; - case 'w': - if ((i%3) != 1) { - goto chmodStyleCheck; - } - newMode |= (1<<(8-i)); - break; - case 'x': - if ((i%3) != 2) { - goto chmodStyleCheck; - } - newMode |= (1<<(8-i)); - break; - case 's': - if (((i%3) != 2) || (i > 5)) { - goto chmodStyleCheck; - } - newMode |= (1<<(8-i)); - newMode |= (1<<(11-(i/3))); - break; - case 'S': - if (((i%3) != 2) || (i > 5)) { - goto chmodStyleCheck; - } - newMode |= (1<<(11-(i/3))); - break; - case 't': - if (i != 8) { - goto chmodStyleCheck; - } - newMode |= (1<<(8-i)); - newMode |= (1<<9); - break; - case 'T': - if (i != 8) { - goto chmodStyleCheck; - } - newMode |= (1<<9); - break; - case '-': - break; - default: - /* - * Oops, not what we thought it was, so go on - */ - goto chmodStyleCheck; - } - } - *modePtr = newMode; - return TCL_OK; - - chmodStyleCheck: - /* - * We now check for an "ugoa+-=rwxst" style permissions string - */ - - for (n = 0 ; *(modeStringPtr+n) != '\0' ; n = n + i) { - oldMode = *modePtr; - who = op = what = op_found = who_found = 0; - for (i = 0 ; *(modeStringPtr+n+i) != '\0' ; i++ ) { - if (!who_found) { - /* who */ - switch (*(modeStringPtr+n+i)) { - case 'u' : - who |= 0x9c0; - continue; - case 'g' : - who |= 0x438; - continue; - case 'o' : - who |= 0x207; - continue; - case 'a' : - who |= 0xfff; - continue; - } - } - who_found = 1; - if (who == 0) { - who = 0xfff; - } - if (!op_found) { - /* op */ - switch (*(modeStringPtr+n+i)) { - case '+' : - op = 1; - op_found = 1; - continue; - case '-' : - op = 2; - op_found = 1; - continue; - case '=' : - op = 3; - op_found = 1; - continue; - default : - return TCL_ERROR; - break; - } - } - /* what */ - switch (*(modeStringPtr+n+i)) { - case 'r' : - what |= 0x124; - continue; - case 'w' : - what |= 0x92; - continue; - case 'x' : - what |= 0x49; - continue; - case 's' : - what |= 0xc00; - continue; - case 't' : - what |= 0x200; - continue; - case ',' : - break; - default : - return TCL_ERROR; - break; - } - if (*(modeStringPtr+n+i) == ',') { - i++; - break; - } - } - switch (op) { - case 1 : - *modePtr = oldMode | (who & what); - continue; - case 2 : - *modePtr = oldMode & ~(who & what); - continue; - case 3 : - *modePtr = (oldMode & ~who) | (who & what); - continue; - } - } - return TCL_OK; -} diff --git a/unix/tclUnixFile.c b/unix/tclUnixFile.c deleted file mode 100644 index 2679fdb..0000000 --- a/unix/tclUnixFile.c +++ /dev/null @@ -1,696 +0,0 @@ -/* - * tclUnixFile.c -- - * - * This file contains wrappers around UNIX file handling functions. - * These wrappers mask differences between Windows and UNIX. - * - * Copyright (c) 1995-1998 Sun Microsystems, Inc. - * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclUnixFile.c,v 1.9 2000/01/11 22:09:19 hobbs Exp $ - */ - -#include "tclInt.h" -#include "tclPort.h" - - -/* - *--------------------------------------------------------------------------- - * - * TclpFindExecutable -- - * - * This procedure computes the absolute path name of the current - * application, given its argv[0] value. - * - * Results: - * A dirty UTF string that is the path to the executable. At this - * point we may not know the system encoding. Convert the native - * string value to UTF using the default encoding. The assumption - * is that we will still be able to parse the path given the path - * name contains ASCII string and '/' chars do not conflict with - * other UTF chars. - * - * Side effects: - * The variable tclNativeExecutableName gets filled in with the file - * name for the application, if we figured it out. If we couldn't - * figure it out, tclNativeExecutableName is set to NULL. - * - *--------------------------------------------------------------------------- - */ - -char * -TclpFindExecutable(argv0) - CONST char *argv0; /* The value of the application's argv[0] - * (native). */ -{ - CONST char *name, *p; - struct stat statBuf; - int length; - Tcl_DString buffer, nameString; - - if (argv0 == NULL) { - return NULL; - } - if (tclNativeExecutableName != NULL) { - return tclNativeExecutableName; - } - - Tcl_DStringInit(&buffer); - - name = argv0; - for (p = name; *p != '\0'; p++) { - if (*p == '/') { - /* - * The name contains a slash, so use the name directly - * without doing a path search. - */ - - goto gotName; - } - } - - p = getenv("PATH"); /* INTL: Native. */ - if (p == NULL) { - /* - * There's no PATH environment variable; use the default that - * is used by sh. - */ - - p = ":/bin:/usr/bin"; - } else if (*p == '\0') { - /* - * An empty path is equivalent to ".". - */ - - p = "./"; - } - - /* - * Search through all the directories named in the PATH variable - * to see if argv[0] is in one of them. If so, use that file - * name. - */ - - while (1) { - while (isspace(UCHAR(*p))) { /* INTL: BUG */ - p++; - } - name = p; - while ((*p != ':') && (*p != 0)) { - p++; - } - Tcl_DStringSetLength(&buffer, 0); - if (p != name) { - Tcl_DStringAppend(&buffer, name, p - name); - if (p[-1] != '/') { - Tcl_DStringAppend(&buffer, "/", 1); - } - } - name = Tcl_DStringAppend(&buffer, argv0, -1); - - /* - * INTL: The following calls to access() and stat() should not be - * converted to Tclp routines because they need to operate on native - * strings directly. - */ - - if ((access(name, X_OK) == 0) /* INTL: Native. */ - && (stat(name, &statBuf) == 0) /* INTL: Native. */ - && S_ISREG(statBuf.st_mode)) { - goto gotName; - } - if (*p == '\0') { - break; - } else if (*(p+1) == 0) { - p = "./"; - } else { - p++; - } - } - goto done; - - /* - * If the name starts with "/" then just copy it to tclExecutableName. - */ - - gotName: - if (name[0] == '/') { - Tcl_ExternalToUtfDString(NULL, name, -1, &nameString); - tclNativeExecutableName = (char *) - ckalloc((unsigned) (Tcl_DStringLength(&nameString) + 1)); - strcpy(tclNativeExecutableName, Tcl_DStringValue(&nameString)); - Tcl_DStringFree(&nameString); - goto done; - } - - /* - * The name is relative to the current working directory. First - * strip off a leading "./", if any, then add the full path name of - * the current working directory. - */ - - if ((name[0] == '.') && (name[1] == '/')) { - name += 2; - } - - Tcl_ExternalToUtfDString(NULL, name, -1, &nameString); - - Tcl_DStringFree(&buffer); - TclpGetCwd(NULL, &buffer); - - length = Tcl_DStringLength(&buffer) + Tcl_DStringLength(&nameString) + 2; - tclNativeExecutableName = (char *) ckalloc((unsigned) length); - strcpy(tclNativeExecutableName, Tcl_DStringValue(&buffer)); - tclNativeExecutableName[Tcl_DStringLength(&buffer)] = '/'; - strcpy(tclNativeExecutableName + Tcl_DStringLength(&buffer) + 1, - Tcl_DStringValue(&nameString)); - Tcl_DStringFree(&nameString); - - done: - Tcl_DStringFree(&buffer); - return tclNativeExecutableName; -} - -/* - *---------------------------------------------------------------------- - * - * TclpMatchFilesTypes -- - * - * This routine is used by the globbing code to search a - * directory for all files which match a given pattern. - * - * Results: - * If the tail argument is NULL, then the matching files are - * added to the the interp's result. Otherwise, TclDoGlob is called - * recursively for each matching subdirectory. The return value - * is a standard Tcl result indicating whether an error occurred - * in globbing. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -TclpMatchFilesTypes(interp, separators, dirPtr, pattern, tail, types) - Tcl_Interp *interp; /* Interpreter to receive results. */ - char *separators; /* Directory separators to pass to TclDoGlob */ - Tcl_DString *dirPtr; /* Contains path to directory to search. */ - char *pattern; /* Pattern to match against. */ - char *tail; /* Pointer to end of pattern. Tail must - * point to a location in pattern and must - * not be static. */ - GlobTypeData *types; /* Object containing list of acceptable types. - * May be NULL. */ -{ - char *native, *fname, *dirName, *patternEnd = tail; - char savedChar = 0; /* lint. */ - DIR *d; - Tcl_DString ds; - struct stat statBuf; - int matchHidden; - int result = TCL_OK; - int baseLength = Tcl_DStringLength(dirPtr); - Tcl_Obj *resultPtr; - - /* - * Make sure that the directory part of the name really is a - * directory. If the directory name is "", use the name "." - * instead, because some UNIX systems don't treat "" like "." - * automatically. Keep the "" for use in generating file names, - * otherwise "glob foo.c" would return "./foo.c". - */ - - if (Tcl_DStringLength(dirPtr) == 0) { - dirName = "."; - } else { - dirName = Tcl_DStringValue(dirPtr); - } - - if ((TclpStat(dirName, &statBuf) != 0) /* INTL: UTF-8. */ - || !S_ISDIR(statBuf.st_mode)) { - return TCL_OK; - } - - /* - * Check to see if the pattern needs to compare with hidden files. - */ - - if ((pattern[0] == '.') - || ((pattern[0] == '\\') && (pattern[1] == '.'))) { - matchHidden = 1; - } else { - matchHidden = 0; - } - - /* - * Now open the directory for reading and iterate over the contents. - */ - - native = Tcl_UtfToExternalDString(NULL, dirName, -1, &ds); - d = opendir(native); /* INTL: Native. */ - Tcl_DStringFree(&ds); - if (d == NULL) { - Tcl_ResetResult(interp); - - /* - * Strip off a trailing '/' if necessary, before reporting the error. - */ - - if (baseLength > 0) { - savedChar = (Tcl_DStringValue(dirPtr))[baseLength-1]; - if (savedChar == '/') { - (Tcl_DStringValue(dirPtr))[baseLength-1] = '\0'; - } - } - Tcl_AppendResult(interp, "couldn't read directory \"", - Tcl_DStringValue(dirPtr), "\": ", - Tcl_PosixError(interp), (char *) NULL); - if (baseLength > 0) { - (Tcl_DStringValue(dirPtr))[baseLength-1] = savedChar; - } - return TCL_ERROR; - } - - /* - * Clean up the end of the pattern and the tail pointer. Leave - * the tail pointing to the first character after the path separator - * following the pattern, or NULL. Also, ensure that the pattern - * is null-terminated. - */ - - if (*tail == '\\') { - tail++; - } - if (*tail == '\0') { - tail = NULL; - } else { - tail++; - } - savedChar = *patternEnd; - *patternEnd = '\0'; - - resultPtr = Tcl_GetObjResult(interp); - while (1) { - char *utf; - struct dirent *entryPtr; - - entryPtr = readdir(d); /* INTL: Native. */ - if (entryPtr == NULL) { - break; - } - - if (types != NULL && (types->perm & TCL_GLOB_PERM_HIDDEN)) { - /* - * We explicitly asked for hidden files, so turn around - * and ignore any file which isn't hidden. - */ - if (*entryPtr->d_name != '.') { - continue; - } - } else if (!matchHidden && (*entryPtr->d_name == '.')) { - /* - * Don't match names starting with "." unless the "." is - * present in the pattern. - */ - continue; - } - - /* - * Now check to see if the file matches. If there are more - * characters to be processed, then ensure matching files are - * directories before calling TclDoGlob. Otherwise, just add - * the file to the result. - */ - - utf = Tcl_ExternalToUtfDString(NULL, entryPtr->d_name, -1, &ds); - if (Tcl_StringMatch(utf, pattern) != 0) { - Tcl_DStringSetLength(dirPtr, baseLength); - Tcl_DStringAppend(dirPtr, utf, -1); - fname = Tcl_DStringValue(dirPtr); - if (tail == NULL) { - int typeOk = 1; - if (types != NULL) { - if (types->perm != 0) { - struct stat buf; - - if (TclpStat(fname, &buf) != 0) { - panic("stat failed on known file"); - } - /* - * readonly means that there are NO write permissions - * (even for user), but execute is OK for anybody - */ - if ( - ((types->perm & TCL_GLOB_PERM_RONLY) && - (buf.st_mode & (S_IWOTH|S_IWGRP|S_IWUSR))) || - ((types->perm & TCL_GLOB_PERM_R) && - (TclpAccess(fname, R_OK) != 0)) || - ((types->perm & TCL_GLOB_PERM_W) && - (TclpAccess(fname, W_OK) != 0)) || - ((types->perm & TCL_GLOB_PERM_X) && - (TclpAccess(fname, X_OK) != 0)) - ) { - typeOk = 0; - } - } - if (typeOk && (types->type != 0)) { - struct stat buf; - /* - * We must match at least one flag to be listed - */ - typeOk = 0; - if (TclpLstat(fname, &buf) >= 0) { - /* - * In order bcdpfls as in 'find -t' - */ - if ( - ((types->type & TCL_GLOB_TYPE_BLOCK) && - S_ISBLK(buf.st_mode)) || - ((types->type & TCL_GLOB_TYPE_CHAR) && - S_ISCHR(buf.st_mode)) || - ((types->type & TCL_GLOB_TYPE_DIR) && - S_ISDIR(buf.st_mode)) || - ((types->type & TCL_GLOB_TYPE_PIPE) && - S_ISFIFO(buf.st_mode)) || - ((types->type & TCL_GLOB_TYPE_FILE) && - S_ISREG(buf.st_mode)) -#ifdef S_ISLNK - || ((types->type & TCL_GLOB_TYPE_LINK) && - S_ISLNK(buf.st_mode)) -#endif -#ifdef S_ISSOCK - || ((types->type & TCL_GLOB_TYPE_SOCK) && - S_ISSOCK(buf.st_mode)) -#endif - ) { - typeOk = 1; - } - } else { - /* Posix error occurred */ - } - } - } - if (typeOk) { - Tcl_ListObjAppendElement(interp, resultPtr, - Tcl_NewStringObj(fname, - Tcl_DStringLength(dirPtr))); - } - } else if ((TclpStat(fname, &statBuf) == 0) - && S_ISDIR(statBuf.st_mode)) { - Tcl_DStringAppend(dirPtr, "/", 1); - result = TclDoGlob(interp, separators, dirPtr, tail, types); - if (result != TCL_OK) { - Tcl_DStringFree(&ds); - break; - } - } - } - Tcl_DStringFree(&ds); - } - *patternEnd = savedChar; - - closedir(d); - return result; -} - -/* - * TclpMatchFiles -- - * - * This function is now obsolete. Call the above function - * 'TclpMatchFilesTypes' instead. - */ -int -TclpMatchFiles(interp, separators, dirPtr, pattern, tail) - Tcl_Interp *interp; /* Interpreter to receive results. */ - char *separators; /* Directory separators to pass to TclDoGlob */ - Tcl_DString *dirPtr; /* Contains path to directory to search. */ - char *pattern; /* Pattern to match against. */ - char *tail; /* Pointer to end of pattern. Tail must - * point to a location in pattern and must - * not be static. */ -{ - return TclpMatchFilesTypes(interp,separators,dirPtr,pattern,tail,NULL); -} - -/* - *--------------------------------------------------------------------------- - * - * TclpGetUserHome -- - * - * This function takes the specified user name and finds their - * home directory. - * - * Results: - * The result is a pointer to a string specifying the user's home - * directory, or NULL if the user's home directory could not be - * determined. Storage for the result string is allocated in - * bufferPtr; the caller must call Tcl_DStringFree() when the result - * is no longer needed. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -char * -TclpGetUserHome(name, bufferPtr) - CONST char *name; /* User name for desired home directory. */ - Tcl_DString *bufferPtr; /* Uninitialized or free DString filled - * with name of user's home directory. */ -{ - struct passwd *pwPtr; - Tcl_DString ds; - char *native; - - native = Tcl_UtfToExternalDString(NULL, name, -1, &ds); - pwPtr = getpwnam(native); /* INTL: Native. */ - Tcl_DStringFree(&ds); - - if (pwPtr == NULL) { - endpwent(); - return NULL; - } - Tcl_ExternalToUtfDString(NULL, pwPtr->pw_dir, -1, bufferPtr); - endpwent(); - return Tcl_DStringValue(bufferPtr); -} - -/* - *--------------------------------------------------------------------------- - * - * TclpAccess -- - * - * This function replaces the library version of access(). - * - * Results: - * See access() documentation. - * - * Side effects: - * See access() documentation. - * - *--------------------------------------------------------------------------- - */ - -int -TclpAccess(path, mode) - CONST char *path; /* Path of file to access (UTF-8). */ - int mode; /* Permission setting. */ -{ - int result; - Tcl_DString ds; - char *native; - - native = Tcl_UtfToExternalDString(NULL, path, -1, &ds); - result = access(native, mode); /* INTL: Native. */ - Tcl_DStringFree(&ds); - - return result; -} - -/* - *--------------------------------------------------------------------------- - * - * TclpChdir -- - * - * This function replaces the library version of chdir(). - * - * Results: - * See chdir() documentation. - * - * Side effects: - * See chdir() documentation. - * - *--------------------------------------------------------------------------- - */ - -int -TclpChdir(dirName) - CONST char *dirName; /* Path to new working directory (UTF-8). */ -{ - int result; - Tcl_DString ds; - char *native; - - native = Tcl_UtfToExternalDString(NULL, dirName, -1, &ds); - result = chdir(native); /* INTL: Native. */ - Tcl_DStringFree(&ds); - - return result; -} - -/* - *---------------------------------------------------------------------- - * - * TclpLstat -- - * - * This function replaces the library version of lstat(). - * - * Results: - * See lstat() documentation. - * - * Side effects: - * See lstat() documentation. - * - *---------------------------------------------------------------------- - */ - -int -TclpLstat(path, bufPtr) - CONST char *path; /* Path of file to stat (UTF-8). */ - struct stat *bufPtr; /* Filled with results of stat call. */ -{ - int result; - Tcl_DString ds; - char *native; - - native = Tcl_UtfToExternalDString(NULL, path, -1, &ds); - result = lstat(native, bufPtr); /* INTL: Native. */ - Tcl_DStringFree(&ds); - - return result; -} - -/* - *--------------------------------------------------------------------------- - * - * TclpGetCwd -- - * - * This function replaces the library version of getcwd(). - * - * Results: - * The result is a pointer to a string specifying the current - * directory, or NULL if the current directory could not be - * determined. If NULL is returned, an error message is left in the - * interp's result. Storage for the result string is allocated in - * bufferPtr; the caller must call Tcl_DStringFree() when the result - * is no longer needed. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -char * -TclpGetCwd(interp, bufferPtr) - Tcl_Interp *interp; /* If non-NULL, used for error reporting. */ - Tcl_DString *bufferPtr; /* Uninitialized or free DString filled - * with name of current directory. */ -{ - char buffer[MAXPATHLEN+1]; - -#ifdef USEGETWD - if (getwd(buffer) == NULL) { /* INTL: Native. */ -#else - if (getcwd(buffer, MAXPATHLEN + 1) == NULL) { /* INTL: Native. */ -#endif - if (interp != NULL) { - Tcl_AppendResult(interp, - "error getting working directory name: ", - Tcl_PosixError(interp), (char *) NULL); - } - return NULL; - } - return Tcl_ExternalToUtfDString(NULL, buffer, -1, bufferPtr); -} - -/* - *--------------------------------------------------------------------------- - * - * TclpReadlink -- - * - * This function replaces the library version of readlink(). - * - * Results: - * The result is a pointer to a string specifying the contents - * of the symbolic link given by 'path', or NULL if the symbolic - * link could not be read. Storage for the result string is - * allocated in bufferPtr; the caller must call Tcl_DStringFree() - * when the result is no longer needed. - * - * Side effects: - * See readlink() documentation. - * - *--------------------------------------------------------------------------- - */ - -char * -TclpReadlink(path, linkPtr) - CONST char *path; /* Path of file to readlink (UTF-8). */ - Tcl_DString *linkPtr; /* Uninitialized or free DString filled - * with contents of link (UTF-8). */ -{ - char link[MAXPATHLEN]; - int length; - char *native; - Tcl_DString ds; - - native = Tcl_UtfToExternalDString(NULL, path, -1, &ds); - length = readlink(native, link, sizeof(link)); /* INTL: Native. */ - Tcl_DStringFree(&ds); - - if (length < 0) { - return NULL; - } - - Tcl_ExternalToUtfDString(NULL, link, length, linkPtr); - return Tcl_DStringValue(linkPtr); -} - -/* - *---------------------------------------------------------------------- - * - * TclpStat -- - * - * This function replaces the library version of stat(). - * - * Results: - * See stat() documentation. - * - * Side effects: - * See stat() documentation. - * - *---------------------------------------------------------------------- - */ - -int -TclpStat(path, bufPtr) - CONST char *path; /* Path of file to stat (in UTF-8). */ - struct stat *bufPtr; /* Filled with results of stat call. */ -{ - int result; - Tcl_DString ds; - char *native; - - native = Tcl_UtfToExternalDString(NULL, path, -1, &ds); - result = stat(native, bufPtr); /* INTL: Native. */ - Tcl_DStringFree(&ds); - - return result; -} - diff --git a/unix/tclUnixInit.c b/unix/tclUnixInit.c deleted file mode 100644 index c3fc8c7..0000000 --- a/unix/tclUnixInit.c +++ /dev/null @@ -1,780 +0,0 @@ -/* - * tclUnixInit.c -- - * - * Contains the Unix-specific interpreter initialization functions. - * - * Copyright (c) 1995-1997 Sun Microsystems, Inc. - * Copyright (c) 1999 by Scriptics Corporation. - * All rights reserved. - * - * RCS: @(#) $Id: tclUnixInit.c,v 1.18.2.1 2000/08/07 21:31:12 hobbs Exp $ - */ - -#include "tclInt.h" -#include "tclPort.h" -#include <locale.h> -#if defined(__FreeBSD__) -# include <floatingpoint.h> -#endif -#if defined(__bsdi__) -# include <sys/param.h> -# if _BSDI_VERSION > 199501 -# include <dlfcn.h> -# endif -#endif - -/* - * The Init script (common to Windows and Unix platforms) is - * defined in tkInitScript.h - */ -#include "tclInitScript.h" - - -/* - * Default directory in which to look for Tcl library scripts. The - * symbol is defined by Makefile. - */ - -static char defaultLibraryDir[sizeof(TCL_LIBRARY)+200] = TCL_LIBRARY; - -/* - * Directory in which to look for packages (each package is typically - * installed as a subdirectory of this directory). The symbol is - * defined by Makefile. - */ - -static char pkgPath[sizeof(TCL_PACKAGE_PATH)+200] = TCL_PACKAGE_PATH; - -/* - * The following table is used to map from Unix locale strings to - * encoding files. - */ - -typedef struct LocaleTable { - CONST char *lang; - CONST char *encoding; -} LocaleTable; - -static CONST LocaleTable localeTable[] = { - {"ja_JP.SJIS", "shiftjis"}, - {"ja_JP.EUC", "euc-jp"}, - {"ja_JP.JIS", "iso2022-jp"}, - {"ja_JP.mscode", "shiftjis"}, - {"ja_JP.ujis", "euc-jp"}, - {"ja_JP", "euc-jp"}, - {"Ja_JP", "shiftjis"}, - {"Jp_JP", "shiftjis"}, - {"japan", "euc-jp"}, -#ifdef hpux - {"japanese", "shiftjis"}, - {"ja", "shiftjis"}, -#else - {"japanese", "euc-jp"}, - {"ja", "euc-jp"}, -#endif - {"japanese.sjis", "shiftjis"}, - {"japanese.euc", "euc-jp"}, - {"japanese-sjis", "shiftjis"}, - {"japanese-ujis", "euc-jp"}, - - {"ko", "euc-kr"}, - {"ko_KR", "euc-kr"}, - {"ko_KR.EUC", "euc-kr"}, - {"ko_KR.euc", "euc-kr"}, - {"ko_KR.eucKR", "euc-kr"}, - {"korean", "euc-kr"}, - - {"ru", "iso8859-5"}, - {"ru_RU", "iso8859-5"}, - {"ru_SU", "iso8859-5"}, - - {"zh", "cp936"}, - - {NULL, NULL} -}; - -/* - *--------------------------------------------------------------------------- - * - * TclpInitPlatform -- - * - * Initialize all the platform-dependant things like signals and - * floating-point error handling. - * - * Called at process initialization time. - * - * Results: - * None. - * - * Side effects: - * None. - * - *--------------------------------------------------------------------------- - */ - -void -TclpInitPlatform() -{ - tclPlatform = TCL_PLATFORM_UNIX; - - /* - * The code below causes SIGPIPE (broken pipe) errors to - * be ignored. This is needed so that Tcl processes don't - * die if they create child processes (e.g. using "exec" or - * "open") that terminate prematurely. The signal handler - * is only set up when the first interpreter is created; - * after this the application can override the handler with - * a different one of its own, if it wants. - */ - -#ifdef SIGPIPE - (void) signal(SIGPIPE, SIG_IGN); -#endif /* SIGPIPE */ - -#ifdef __FreeBSD__ - fpsetround(FP_RN); - fpsetmask(0L); -#endif - -#if defined(__bsdi__) && (_BSDI_VERSION > 199501) - /* - * Find local symbols. Don't report an error if we fail. - */ - (void) dlopen (NULL, RTLD_NOW); /* INTL: Native. */ -#endif -} - -/* - *--------------------------------------------------------------------------- - * - * TclpInitLibraryPath -- - * - * Initialize the library path at startup. We have a minor - * metacircular problem that we don't know the encoding of the - * operating system but we may need to talk to operating system - * to find the library directories so that we know how to talk to - * the operating system. - * - * We do not know the encoding of the operating system. - * We do know that the encoding is some multibyte encoding. - * In that multibyte encoding, the characters 0..127 are equivalent - * to ascii. - * - * So although we don't know the encoding, it's safe: - * to look for the last slash character in a path in the encoding. - * to append an ascii string to a path. - * to pass those strings back to the operating system. - * - * But any strings that we remembered before we knew the encoding of - * the operating system must be translated to UTF-8 once we know the - * encoding so that the rest of Tcl can use those strings. - * - * This call sets the library path to strings in the unknown native - * encoding. TclpSetInitialEncodings() will translate the library - * path from the native encoding to UTF-8 as soon as it determines - * what the native encoding actually is. - * - * Called at process initialization time. - * - * Results: - * None. - * - * Side effects: - * None. - * - *--------------------------------------------------------------------------- - */ - -void -TclpInitLibraryPath(path) -CONST char *path; /* Path to the executable in native - * multi-byte encoding. */ -{ -#define LIBRARY_SIZE 32 - Tcl_Obj *pathPtr, *objPtr; - char *str; - Tcl_DString buffer, ds; - int pathc; - char **pathv; - char installLib[LIBRARY_SIZE], developLib[LIBRARY_SIZE]; - - Tcl_DStringInit(&ds); - pathPtr = Tcl_NewObj(); - - /* - * Initialize the substrings used when locating an executable. The - * installLib variable computes the path as though the executable - * is installed. The developLib computes the path as though the - * executable is run from a develpment directory. - */ - - sprintf(installLib, "lib/tcl%s", TCL_VERSION); - sprintf(developLib, "tcl%s/library", - ((TCL_RELEASE_LEVEL < 2) ? TCL_PATCH_LEVEL : TCL_VERSION)); - - /* - * Look for the library relative to default encoding dir. - */ - - str = Tcl_GetDefaultEncodingDir(); - if ((str != NULL) && (str[0] != '\0')) { - objPtr = Tcl_NewStringObj(str, -1); - Tcl_ListObjAppendElement(NULL, pathPtr, objPtr); - } - - /* - * Look for the library relative to the TCL_LIBRARY env variable. - * If the last dirname in the TCL_LIBRARY path does not match the - * last dirname in the installLib variable, use the last dir name - * of installLib in addition to the orginal TCL_LIBRARY path. - */ - - str = getenv("TCL_LIBRARY"); /* INTL: Native. */ - Tcl_ExternalToUtfDString(NULL, str, -1, &buffer); - str = Tcl_DStringValue(&buffer); - - if ((str != NULL) && (str[0] != '\0')) { - /* - * If TCL_LIBRARY is set, search there. - */ - - objPtr = Tcl_NewStringObj(str, -1); - Tcl_ListObjAppendElement(NULL, pathPtr, objPtr); - - Tcl_SplitPath(str, &pathc, &pathv); - if ((pathc > 0) && (strcasecmp(installLib + 4, pathv[pathc-1]) != 0)) { - /* - * If TCL_LIBRARY is set but refers to a different tcl - * installation than the current version, try fiddling with the - * specified directory to make it refer to this installation by - * removing the old "tclX.Y" and substituting the current - * version string. - */ - - pathv[pathc - 1] = installLib + 4; - str = Tcl_JoinPath(pathc, pathv, &ds); - objPtr = Tcl_NewStringObj(str, Tcl_DStringLength(&ds)); - Tcl_ListObjAppendElement(NULL, pathPtr, objPtr); - Tcl_DStringFree(&ds); - } - ckfree((char *) pathv); - } - - /* - * Look for the library relative to the executable. This algorithm - * should be the same as the one in the tcl_findLibrary procedure. - * - * This code looks in the following directories: - * - * <bindir>/../<installLib> - * (e.g. /usr/local/bin/../lib/tcl8.2) - * <bindir>/../../<installLib> - * (e.g. /usr/local/TclPro/solaris-sparc/bin/../../lib/tcl8.2) - * <bindir>/../library - * (e.g. /usr/src/tcl8.2/unix/../library) - * <bindir>/../../library - * (e.g. /usr/src/tcl8.2/unix/solaris-sparc/../../library) - * <bindir>/../../<developLib> - * (e.g. /usr/src/tcl8.2/unix/../../tcl8.2/library) - * <bindir>/../../../<devlopLib> - * (e.g. /usr/src/tcl8.2/unix/solaris-sparc/../../../tcl8.2/library) - */ - - if (path != NULL) { - Tcl_SplitPath(path, &pathc, &pathv); - if (pathc > 1) { - pathv[pathc - 2] = installLib; - path = Tcl_JoinPath(pathc - 1, pathv, &ds); - objPtr = Tcl_NewStringObj(path, Tcl_DStringLength(&ds)); - Tcl_ListObjAppendElement(NULL, pathPtr, objPtr); - Tcl_DStringFree(&ds); - } - if (pathc > 2) { - pathv[pathc - 3] = installLib; - path = Tcl_JoinPath(pathc - 2, pathv, &ds); - objPtr = Tcl_NewStringObj(path, Tcl_DStringLength(&ds)); - Tcl_ListObjAppendElement(NULL, pathPtr, objPtr); - Tcl_DStringFree(&ds); - } - if (pathc > 1) { - pathv[pathc - 2] = "library"; - path = Tcl_JoinPath(pathc - 1, pathv, &ds); - objPtr = Tcl_NewStringObj(path, Tcl_DStringLength(&ds)); - Tcl_ListObjAppendElement(NULL, pathPtr, objPtr); - Tcl_DStringFree(&ds); - } - if (pathc > 2) { - pathv[pathc - 3] = "library"; - path = Tcl_JoinPath(pathc - 2, pathv, &ds); - objPtr = Tcl_NewStringObj(path, Tcl_DStringLength(&ds)); - Tcl_ListObjAppendElement(NULL, pathPtr, objPtr); - Tcl_DStringFree(&ds); - } - if (pathc > 1) { - pathv[pathc - 3] = developLib; - path = Tcl_JoinPath(pathc - 2, pathv, &ds); - objPtr = Tcl_NewStringObj(path, Tcl_DStringLength(&ds)); - Tcl_ListObjAppendElement(NULL, pathPtr, objPtr); - Tcl_DStringFree(&ds); - } - if (pathc > 3) { - pathv[pathc - 4] = developLib; - path = Tcl_JoinPath(pathc - 3, pathv, &ds); - objPtr = Tcl_NewStringObj(path, Tcl_DStringLength(&ds)); - Tcl_ListObjAppendElement(NULL, pathPtr, objPtr); - Tcl_DStringFree(&ds); - } - ckfree((char *) pathv); - } - - /* - * Finally, look for the library relative to the compiled-in path. - * This is needed when users install Tcl with an exec-prefix that - * is different from the prtefix. - */ - - str = defaultLibraryDir; - if (str[0] != '\0') { - objPtr = Tcl_NewStringObj(str, -1); - Tcl_ListObjAppendElement(NULL, pathPtr, objPtr); - } - - TclSetLibraryPath(pathPtr); - Tcl_DStringFree(&buffer); -} - -/* - *--------------------------------------------------------------------------- - * - * TclpSetInitialEncodings -- - * - * Based on the locale, determine the encoding of the operating - * system and the default encoding for newly opened files. - * - * Called at process initialization time. - * - * Results: - * None. - * - * Side effects: - * The Tcl library path is converted from native encoding to UTF-8. - * - *--------------------------------------------------------------------------- - */ - -void -TclpSetInitialEncodings() -{ - CONST char *encoding; - int i; - Tcl_Obj *pathPtr; - char *langEnv; - - /* - * Determine the current encoding from the LC_* or LANG environment - * variables. We previously used setlocale() to determine the locale, - * but this does not work on some systems (e.g. Linux/i386 RH 5.0). - */ - - langEnv = getenv("LC_ALL"); - - if (langEnv == NULL || langEnv[0] == '\0') { - langEnv = getenv("LC_CTYPE"); - } - if (langEnv == NULL || langEnv[0] == '\0') { - langEnv = getenv("LANG"); - } - if (langEnv == NULL || langEnv[0] == '\0') { - langEnv = NULL; - } - - encoding = NULL; - if (langEnv != NULL) { - for (i = 0; localeTable[i].lang != NULL; i++) { - if (strcmp(localeTable[i].lang, langEnv) == 0) { - encoding = localeTable[i].encoding; - break; - } - } - /* - * There was no mapping in the locale table. If there is an - * encoding subfield, we can try to guess from that. - */ - - if (encoding == NULL) { - char *p; - for (p = langEnv; *p != '\0'; p++) { - if (*p == '.') { - p++; - break; - } - } - if (*p != '\0') { - Tcl_DString ds; - Tcl_DStringInit(&ds); - Tcl_DStringAppend(&ds, p, -1); - - encoding = Tcl_DStringValue(&ds); - Tcl_UtfToLower(Tcl_DStringValue(&ds)); - if (Tcl_SetSystemEncoding(NULL, encoding) == TCL_OK) { - Tcl_DStringFree(&ds); - goto resetPath; - } - Tcl_DStringFree(&ds); - encoding = NULL; - } - } - } - if (encoding == NULL) { - encoding = "iso8859-1"; - } - - Tcl_SetSystemEncoding(NULL, encoding); - - resetPath: - /* - * Initialize the C library's locale subsystem. This is required - * for input methods to work properly on X11. We only do this for - * LC_CTYPE because that's the necessary one, and we don't want to - * affect LC_TIME here. The side effect of setting the default locale - * should be to load any locale specific modules that are needed by X. - * [BUG: 5422 3345 4236 2522 2521]. - */ - - setlocale(LC_CTYPE, ""); - - /* - * In case the initial locale is not "C", ensure that the numeric - * processing is done in "C" locale regardless. This is needed because - * Tcl relies on routines like strtod, but should not have locale - * dependent behavior. - */ - - setlocale(LC_NUMERIC, "C"); - - /* - * Until the system encoding was actually set, the library path was - * actually in the native multi-byte encoding, and not really UTF-8 - * as advertised. We cheated as follows: - * - * 1. It was safe to allow the Tcl_SetSystemEncoding() call to - * append the ASCII chars that make up the encoding's filename to - * the names (in the native encoding) of directories in the library - * path, since all Unix multi-byte encodings have ASCII in the - * beginning. - * - * 2. To open the encoding file, the native bytes in the file name - * were passed to the OS, without translating from UTF-8 to native, - * because the name was already in the native encoding. - * - * Now that the system encoding was actually successfully set, - * translate all the names in the library path to UTF-8. That way, - * next time we search the library path, we'll translate the names - * from UTF-8 to the system encoding which will be the native - * encoding. - */ - - pathPtr = TclGetLibraryPath(); - if (pathPtr != NULL) { - int objc; - Tcl_Obj **objv; - - objc = 0; - Tcl_ListObjGetElements(NULL, pathPtr, &objc, &objv); - for (i = 0; i < objc; i++) { - int length; - char *string; - Tcl_DString ds; - - string = Tcl_GetStringFromObj(objv[i], &length); - Tcl_ExternalToUtfDString(NULL, string, length, &ds); - Tcl_SetStringObj(objv[i], Tcl_DStringValue(&ds), - Tcl_DStringLength(&ds)); - Tcl_DStringFree(&ds); - } - } - - /* - * Keep the iso8859-1 encoding preloaded. The IO package uses it for - * gets on a binary channel. - */ - - Tcl_GetEncoding(NULL, "iso8859-1"); -} - -/* - *--------------------------------------------------------------------------- - * - * TclpSetVariables -- - * - * Performs platform-specific interpreter initialization related to - * the tcl_library and tcl_platform variables, and other platform- - * specific things. - * - * Results: - * None. - * - * Side effects: - * Sets "tclDefaultLibrary", "tcl_pkgPath", and "tcl_platform" Tcl - * variables. - * - *---------------------------------------------------------------------- - */ - -void -TclpSetVariables(interp) - Tcl_Interp *interp; -{ -#ifndef NO_UNAME - struct utsname name; -#endif - int unameOK; - char *user; - Tcl_DString ds; - - Tcl_SetVar(interp, "tclDefaultLibrary", defaultLibraryDir, TCL_GLOBAL_ONLY); - Tcl_SetVar(interp, "tcl_pkgPath", pkgPath, TCL_GLOBAL_ONLY); - Tcl_SetVar2(interp, "tcl_platform", "platform", "unix", TCL_GLOBAL_ONLY); - unameOK = 0; -#ifndef NO_UNAME - if (uname(&name) >= 0) { - char *native; - - unameOK = 1; - - native = Tcl_ExternalToUtfDString(NULL, name.sysname, -1, &ds); - Tcl_SetVar2(interp, "tcl_platform", "os", native, TCL_GLOBAL_ONLY); - Tcl_DStringFree(&ds); - - /* - * The following code is a special hack to handle differences in - * the way version information is returned by uname. On most - * systems the full version number is available in name.release. - * However, under AIX the major version number is in - * name.version and the minor version number is in name.release. - */ - - if ((strchr(name.release, '.') != NULL) - || !isdigit(UCHAR(name.version[0]))) { /* INTL: digit */ - Tcl_SetVar2(interp, "tcl_platform", "osVersion", name.release, - TCL_GLOBAL_ONLY); - } else { - Tcl_SetVar2(interp, "tcl_platform", "osVersion", name.version, - TCL_GLOBAL_ONLY); - Tcl_SetVar2(interp, "tcl_platform", "osVersion", ".", - TCL_GLOBAL_ONLY|TCL_APPEND_VALUE); - Tcl_SetVar2(interp, "tcl_platform", "osVersion", name.release, - TCL_GLOBAL_ONLY|TCL_APPEND_VALUE); - } - Tcl_SetVar2(interp, "tcl_platform", "machine", name.machine, - TCL_GLOBAL_ONLY); - } -#endif - if (!unameOK) { - Tcl_SetVar2(interp, "tcl_platform", "os", "", TCL_GLOBAL_ONLY); - Tcl_SetVar2(interp, "tcl_platform", "osVersion", "", TCL_GLOBAL_ONLY); - Tcl_SetVar2(interp, "tcl_platform", "machine", "", TCL_GLOBAL_ONLY); - } - - /* - * Copy USER or LOGNAME environment variable into tcl_platform(user) - */ - - Tcl_DStringInit(&ds); - user = TclGetEnv("USER", &ds); - if (user == NULL) { - user = TclGetEnv("LOGNAME", &ds); - if (user == NULL) { - user = ""; - } - } - Tcl_SetVar2(interp, "tcl_platform", "user", user, TCL_GLOBAL_ONLY); - Tcl_DStringFree(&ds); - -} - -/* - *---------------------------------------------------------------------- - * - * TclpFindVariable -- - * - * Locate the entry in environ for a given name. On Unix this - * routine is case sensetive, on Windows this matches mixed case. - * - * Results: - * The return value is the index in environ of an entry with the - * name "name", or -1 if there is no such entry. The integer at - * *lengthPtr is filled in with the length of name (if a matching - * entry is found) or the length of the environ array (if no matching - * entry is found). - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -TclpFindVariable(name, lengthPtr) - CONST char *name; /* Name of desired environment variable - * (native). */ - int *lengthPtr; /* Used to return length of name (for - * successful searches) or number of non-NULL - * entries in environ (for unsuccessful - * searches). */ -{ - int i, result = -1; - register CONST char *env, *p1, *p2; - Tcl_DString envString; - - Tcl_DStringInit(&envString); - for (i = 0, env = environ[i]; env != NULL; i++, env = environ[i]) { - p1 = Tcl_ExternalToUtfDString(NULL, env, -1, &envString); - p2 = name; - - for (; *p2 == *p1; p1++, p2++) { - /* NULL loop body. */ - } - if ((*p1 == '=') && (*p2 == '\0')) { - *lengthPtr = p2 - name; - result = i; - goto done; - } - - Tcl_DStringFree(&envString); - } - - *lengthPtr = i; - - done: - Tcl_DStringFree(&envString); - return result; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_Init -- - * - * This procedure is typically invoked by Tcl_AppInit procedures - * to find and source the "init.tcl" script, which should exist - * somewhere on the Tcl library path. - * - * Results: - * Returns a standard Tcl completion code and sets the interp's - * result if there is an error. - * - * Side effects: - * Depends on what's in the init.tcl script. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_Init(interp) - Tcl_Interp *interp; /* Interpreter to initialize. */ -{ - Tcl_Obj *pathPtr; - - if (tclPreInitScript != NULL) { - if (Tcl_Eval(interp, tclPreInitScript) == TCL_ERROR) { - return (TCL_ERROR); - }; - } - - pathPtr = TclGetLibraryPath(); - if (pathPtr == NULL) { - pathPtr = Tcl_NewObj(); - } - Tcl_SetVar2Ex(interp, "tcl_libPath", NULL, pathPtr, TCL_GLOBAL_ONLY); - return Tcl_Eval(interp, initScript); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_SourceRCFile -- - * - * This procedure is typically invoked by Tcl_Main of Tk_Main - * procedure to source an application specific rc file into the - * interpreter at startup time. - * - * Results: - * None. - * - * Side effects: - * Depends on what's in the rc script. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_SourceRCFile(interp) - Tcl_Interp *interp; /* Interpreter to source rc file into. */ -{ - Tcl_DString temp; - char *fileName; - Tcl_Channel errChannel; - - fileName = Tcl_GetVar(interp, "tcl_rcFileName", TCL_GLOBAL_ONLY); - - if (fileName != NULL) { - Tcl_Channel c; - char *fullName; - - Tcl_DStringInit(&temp); - fullName = Tcl_TranslateFileName(interp, fileName, &temp); - if (fullName == NULL) { - /* - * Couldn't translate the file name (e.g. it referred to a - * bogus user or there was no HOME environment variable). - * Just do nothing. - */ - } else { - - /* - * Test for the existence of the rc file before trying to read it. - */ - - c = Tcl_OpenFileChannel(NULL, fullName, "r", 0); - if (c != (Tcl_Channel) NULL) { - Tcl_Close(NULL, c); - if (Tcl_EvalFile(interp, fullName) != TCL_OK) { - errChannel = Tcl_GetStdChannel(TCL_STDERR); - if (errChannel) { - Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp)); - Tcl_WriteChars(errChannel, "\n", 1); - } - } - } - } - Tcl_DStringFree(&temp); - } -} - -/* - *---------------------------------------------------------------------- - * - * TclpCheckStackSpace -- - * - * Detect if we are about to blow the stack. Called before an - * evaluation can happen when nesting depth is checked. - * - * Results: - * 1 if there is enough stack space to continue; 0 if not. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -TclpCheckStackSpace() -{ - /* - * This function is unimplemented on Unix platforms. - */ - - return 1; -} diff --git a/unix/tclUnixNotfy.c b/unix/tclUnixNotfy.c deleted file mode 100644 index f376746..0000000 --- a/unix/tclUnixNotfy.c +++ /dev/null @@ -1,1033 +0,0 @@ -/* - * tclUnixNotify.c -- - * - * This file contains the implementation of the select-based - * Unix-specific notifier, which is the lowest-level part of the - * Tcl event loop. This file works together with - * ../generic/tclNotify.c. - * - * Copyright (c) 1995-1997 Sun Microsystems, Inc. - * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclUnixNotfy.c,v 1.10 2000/04/24 23:32:13 hobbs Exp $ - */ - -#include "tclInt.h" -#include "tclPort.h" -#include <signal.h> - -extern TclStubs tclStubs; - -/* - * This structure is used to keep track of the notifier info for a - * a registered file. - */ - -typedef struct FileHandler { - int fd; - int mask; /* Mask of desired events: TCL_READABLE, - * etc. */ - int readyMask; /* Mask of events that have been seen since the - * last time file handlers were invoked for - * this file. */ - Tcl_FileProc *proc; /* Procedure to call, in the style of - * Tcl_CreateFileHandler. */ - ClientData clientData; /* Argument to pass to proc. */ - struct FileHandler *nextPtr;/* Next in list of all files we care about. */ -} FileHandler; - -/* - * The following structure is what is added to the Tcl event queue when - * file handlers are ready to fire. - */ - -typedef struct FileHandlerEvent { - Tcl_Event header; /* Information that is standard for - * all events. */ - int fd; /* File descriptor that is ready. Used - * to find the FileHandler structure for - * the file (can't point directly to the - * FileHandler structure because it could - * go away while the event is queued). */ -} FileHandlerEvent; - -/* - * The following static structure contains the state information for the - * select based implementation of the Tcl notifier. One of these structures - * is created for each thread that is using the notifier. - */ - -typedef struct ThreadSpecificData { - FileHandler *firstFileHandlerPtr; - /* Pointer to head of file handler list. */ - fd_mask checkMasks[3*MASK_SIZE]; - /* This array is used to build up the masks - * to be used in the next call to select. - * Bits are set in response to calls to - * Tcl_CreateFileHandler. */ - fd_mask readyMasks[3*MASK_SIZE]; - /* This array reflects the readable/writable - * conditions that were found to exist by the - * last call to select. */ - int numFdBits; /* Number of valid bits in checkMasks - * (one more than highest fd for which - * Tcl_WatchFile has been called). */ -#ifdef TCL_THREADS - int onList; /* True if it is in this list */ - unsigned int pollState; /* pollState is used to implement a polling - * handshake between each thread and the - * notifier thread. Bits defined below. */ - struct ThreadSpecificData *nextPtr, *prevPtr; - /* All threads that are currently waiting on - * an event have their ThreadSpecificData - * structure on a doubly-linked listed formed - * from these pointers. You must hold the - * notifierMutex lock before accessing these - * fields. */ - Tcl_Condition waitCV; /* Any other thread alerts a notifier - * that an event is ready to be processed - * by signaling this condition variable. */ - int eventReady; /* True if an event is ready to be processed. - * Used as condition flag together with - * waitCV above. */ -#endif -} ThreadSpecificData; - -static Tcl_ThreadDataKey dataKey; - -#ifdef TCL_THREADS -/* - * The following static indicates the number of threads that have - * initialized notifiers. - * - * You must hold the notifierMutex lock before accessing this variable. - */ - -static int notifierCount = 0; - -/* - * The following variable points to the head of a doubly-linked list of - * of ThreadSpecificData structures for all threads that are currently - * waiting on an event. - * - * You must hold the notifierMutex lock before accessing this list. - */ - -static ThreadSpecificData *waitingListPtr = NULL; - -/* - * The notifier thread spends all its time in select() waiting for a - * file descriptor associated with one of the threads on the waitingListPtr - * list to do something interesting. But if the contents of the - * waitingListPtr list ever changes, we need to wake up and restart - * the select() system call. You can wake up the notifier thread by - * writing a single byte to the file descriptor defined below. This - * file descriptor is the input-end of a pipe and the notifier thread is - * listening for data on the output-end of the same pipe. Hence writing - * to this file descriptor will cause the select() system call to return - * and wake up the notifier thread. - * - * You must hold the notifierMutex lock before accessing this list. - */ - -static int triggerPipe = -1; - -/* - * The notifierMutex locks access to all of the global notifier state. - */ - -TCL_DECLARE_MUTEX(notifierMutex) - -/* - * The notifier thread signals the notifierCV when it has finished - * initializing the triggerPipe and right before the notifier - * thread terminates. - */ - -static Tcl_Condition notifierCV; - -/* - * The pollState bits - * POLL_WANT is set by each thread before it waits on its condition - * variable. It is checked by the notifier before it does - * select. - * POLL_DONE is set by the notifier if it goes into select after - * seeing POLL_WANT. The idea is to ensure it tries a select - * with the same bits the initial thread had set. - */ -#define POLL_WANT 0x1 -#define POLL_DONE 0x2 - -/* - * This is the thread ID of the notifier thread that does select. - */ -static Tcl_ThreadId notifierThread; - -#endif - -/* - * Static routines defined in this file. - */ - -#ifdef TCL_THREADS -static void NotifierThreadProc _ANSI_ARGS_((ClientData clientData)); -#endif -static int FileHandlerEventProc _ANSI_ARGS_((Tcl_Event *evPtr, - int flags)); - -/* - *---------------------------------------------------------------------- - * - * Tcl_InitNotifier -- - * - * Initializes the platform specific notifier state. - * - * Results: - * Returns a handle to the notifier state for this thread.. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -ClientData -Tcl_InitNotifier() -{ - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - -#ifdef TCL_THREADS - tsdPtr->eventReady = 0; - - /* - * Start the Notifier thread if necessary. - */ - - Tcl_MutexLock(¬ifierMutex); - if (notifierCount == 0) { - if (Tcl_CreateThread(¬ifierThread, NotifierThreadProc, NULL, - TCL_THREAD_STACK_DEFAULT, TCL_THREAD_NOFLAGS) != TCL_OK) { - panic("Tcl_InitNotifier: unable to start notifier thread"); - } - } - notifierCount++; - - /* - * Wait for the notifier pipe to be created. - */ - - while (triggerPipe < 0) { - Tcl_ConditionWait(¬ifierCV, ¬ifierMutex, NULL); - } - - Tcl_MutexUnlock(¬ifierMutex); -#endif - return (ClientData) tsdPtr; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_FinalizeNotifier -- - * - * This function is called to cleanup the notifier state before - * a thread is terminated. - * - * Results: - * None. - * - * Side effects: - * May terminate the background notifier thread if this is the - * last notifier instance. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_FinalizeNotifier(clientData) - ClientData clientData; /* Not used. */ -{ -#ifdef TCL_THREADS - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - - Tcl_MutexLock(¬ifierMutex); - notifierCount--; - - /* - * If this is the last thread to use the notifier, close the notifier - * pipe and wait for the background thread to terminate. - */ - - if (notifierCount == 0) { - if (triggerPipe < 0) { - panic("Tcl_FinalizeNotifier: notifier pipe not initialized"); - } - - /* - * Send "q" message to the notifier thread so that it will - * terminate. The notifier will return from its call to select() - * and notice that a "q" message has arrived, it will then close - * its side of the pipe and terminate its thread. Note the we can - * not just close the pipe and check for EOF in the notifier - * thread because if a background child process was created with - * exec, select() would not register the EOF on the pipe until the - * child processes had terminated. [Bug: 4139] - */ - write(triggerPipe, "q", 1); - close(triggerPipe); - - Tcl_ConditionWait(¬ifierCV, ¬ifierMutex, NULL); - } - - /* - * Clean up any synchronization objects in the thread local storage. - */ - - Tcl_ConditionFinalize(&(tsdPtr->waitCV)); - - Tcl_MutexUnlock(¬ifierMutex); -#endif -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_AlertNotifier -- - * - * Wake up the specified notifier from any thread. This routine - * is called by the platform independent notifier code whenever - * the Tcl_ThreadAlert routine is called. This routine is - * guaranteed not to be called on a given notifier after - * Tcl_FinalizeNotifier is called for that notifier. - * - * Results: - * None. - * - * Side effects: - * Signals the notifier condition variable for the specified - * notifier. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_AlertNotifier(clientData) - ClientData clientData; -{ -#ifdef TCL_THREADS - ThreadSpecificData *tsdPtr = (ThreadSpecificData *) clientData; - Tcl_MutexLock(¬ifierMutex); - tsdPtr->eventReady = 1; - Tcl_ConditionNotify(&tsdPtr->waitCV); - Tcl_MutexUnlock(¬ifierMutex); -#endif -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_SetTimer -- - * - * This procedure sets the current notifier timer value. This - * interface is not implemented in this notifier because we are - * always running inside of Tcl_DoOneEvent. - * - * Results: - * None. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_SetTimer(timePtr) - Tcl_Time *timePtr; /* Timeout value, may be NULL. */ -{ - /* - * The interval timer doesn't do anything in this implementation, - * because the only event loop is via Tcl_DoOneEvent, which passes - * timeout values to Tcl_WaitForEvent. - */ - - if (tclStubs.tcl_SetTimer != Tcl_SetTimer) { - tclStubs.tcl_SetTimer(timePtr); - } -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_ServiceModeHook -- - * - * This function is invoked whenever the service mode changes. - * - * Results: - * None. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_ServiceModeHook(mode) - int mode; /* Either TCL_SERVICE_ALL, or - * TCL_SERVICE_NONE. */ -{ -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_CreateFileHandler -- - * - * This procedure registers a file handler with the select notifier. - * - * Results: - * None. - * - * Side effects: - * Creates a new file handler structure. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_CreateFileHandler(fd, mask, proc, clientData) - int fd; /* Handle of stream to watch. */ - int mask; /* OR'ed combination of TCL_READABLE, - * TCL_WRITABLE, and TCL_EXCEPTION: - * indicates conditions under which - * proc should be called. */ - Tcl_FileProc *proc; /* Procedure to call for each - * selected event. */ - ClientData clientData; /* Arbitrary data to pass to proc. */ -{ - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - FileHandler *filePtr; - int index, bit; - - if (tclStubs.tcl_CreateFileHandler != Tcl_CreateFileHandler) { - tclStubs.tcl_CreateFileHandler(fd, mask, proc, clientData); - return; - } - - for (filePtr = tsdPtr->firstFileHandlerPtr; filePtr != NULL; - filePtr = filePtr->nextPtr) { - if (filePtr->fd == fd) { - break; - } - } - if (filePtr == NULL) { - filePtr = (FileHandler*) ckalloc(sizeof(FileHandler)); - filePtr->fd = fd; - filePtr->readyMask = 0; - filePtr->nextPtr = tsdPtr->firstFileHandlerPtr; - tsdPtr->firstFileHandlerPtr = filePtr; - } - filePtr->proc = proc; - filePtr->clientData = clientData; - filePtr->mask = mask; - - /* - * Update the check masks for this file. - */ - - index = fd/(NBBY*sizeof(fd_mask)); - bit = 1 << (fd%(NBBY*sizeof(fd_mask))); - if (mask & TCL_READABLE) { - tsdPtr->checkMasks[index] |= bit; - } else { - tsdPtr->checkMasks[index] &= ~bit; - } - if (mask & TCL_WRITABLE) { - (tsdPtr->checkMasks+MASK_SIZE)[index] |= bit; - } else { - (tsdPtr->checkMasks+MASK_SIZE)[index] &= ~bit; - } - if (mask & TCL_EXCEPTION) { - (tsdPtr->checkMasks+2*(MASK_SIZE))[index] |= bit; - } else { - (tsdPtr->checkMasks+2*(MASK_SIZE))[index] &= ~bit; - } - if (tsdPtr->numFdBits <= fd) { - tsdPtr->numFdBits = fd+1; - } -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_DeleteFileHandler -- - * - * Cancel a previously-arranged callback arrangement for - * a file. - * - * Results: - * None. - * - * Side effects: - * If a callback was previously registered on file, remove it. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_DeleteFileHandler(fd) - int fd; /* Stream id for which to remove callback procedure. */ -{ - FileHandler *filePtr, *prevPtr; - int index, bit, i; - unsigned long flags; - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - - if (tclStubs.tcl_DeleteFileHandler != Tcl_DeleteFileHandler) { - tclStubs.tcl_DeleteFileHandler(fd); - return; - } - - /* - * Find the entry for the given file (and return if there isn't one). - */ - - for (prevPtr = NULL, filePtr = tsdPtr->firstFileHandlerPtr; ; - prevPtr = filePtr, filePtr = filePtr->nextPtr) { - if (filePtr == NULL) { - return; - } - if (filePtr->fd == fd) { - break; - } - } - - /* - * Update the check masks for this file. - */ - - index = fd/(NBBY*sizeof(fd_mask)); - bit = 1 << (fd%(NBBY*sizeof(fd_mask))); - - if (filePtr->mask & TCL_READABLE) { - tsdPtr->checkMasks[index] &= ~bit; - } - if (filePtr->mask & TCL_WRITABLE) { - (tsdPtr->checkMasks+MASK_SIZE)[index] &= ~bit; - } - if (filePtr->mask & TCL_EXCEPTION) { - (tsdPtr->checkMasks+2*(MASK_SIZE))[index] &= ~bit; - } - - /* - * Find current max fd. - */ - - if (fd+1 == tsdPtr->numFdBits) { - for (tsdPtr->numFdBits = 0; index >= 0; index--) { - flags = tsdPtr->checkMasks[index] - | (tsdPtr->checkMasks+MASK_SIZE)[index] - | (tsdPtr->checkMasks+2*(MASK_SIZE))[index]; - if (flags) { - for (i = (NBBY*sizeof(fd_mask)); i > 0; i--) { - if (flags & (((unsigned long)1) << (i-1))) { - break; - } - } - tsdPtr->numFdBits = index * (NBBY*sizeof(fd_mask)) + i; - break; - } - } - } - - /* - * Clean up information in the callback record. - */ - - if (prevPtr == NULL) { - tsdPtr->firstFileHandlerPtr = filePtr->nextPtr; - } else { - prevPtr->nextPtr = filePtr->nextPtr; - } - ckfree((char *) filePtr); -} - -/* - *---------------------------------------------------------------------- - * - * FileHandlerEventProc -- - * - * This procedure is called by Tcl_ServiceEvent when a file event - * reaches the front of the event queue. This procedure is - * responsible for actually handling the event by invoking the - * callback for the file handler. - * - * Results: - * Returns 1 if the event was handled, meaning it should be removed - * from the queue. Returns 0 if the event was not handled, meaning - * it should stay on the queue. The only time the event isn't - * handled is if the TCL_FILE_EVENTS flag bit isn't set. - * - * Side effects: - * Whatever the file handler's callback procedure does. - * - *---------------------------------------------------------------------- - */ - -static int -FileHandlerEventProc(evPtr, flags) - Tcl_Event *evPtr; /* Event to service. */ - int flags; /* Flags that indicate what events to - * handle, such as TCL_FILE_EVENTS. */ -{ - int mask; - FileHandler *filePtr; - FileHandlerEvent *fileEvPtr = (FileHandlerEvent *) evPtr; - ThreadSpecificData *tsdPtr; - - if (!(flags & TCL_FILE_EVENTS)) { - return 0; - } - - /* - * Search through the file handlers to find the one whose handle matches - * the event. We do this rather than keeping a pointer to the file - * handler directly in the event, so that the handler can be deleted - * while the event is queued without leaving a dangling pointer. - */ - - tsdPtr = TCL_TSD_INIT(&dataKey); - for (filePtr = tsdPtr->firstFileHandlerPtr; filePtr != NULL; - filePtr = filePtr->nextPtr) { - if (filePtr->fd != fileEvPtr->fd) { - continue; - } - - /* - * The code is tricky for two reasons: - * 1. The file handler's desired events could have changed - * since the time when the event was queued, so AND the - * ready mask with the desired mask. - * 2. The file could have been closed and re-opened since - * the time when the event was queued. This is why the - * ready mask is stored in the file handler rather than - * the queued event: it will be zeroed when a new - * file handler is created for the newly opened file. - */ - - mask = filePtr->readyMask & filePtr->mask; - filePtr->readyMask = 0; - if (mask != 0) { - (*filePtr->proc)(filePtr->clientData, mask); - } - break; - } - return 1; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_WaitForEvent -- - * - * This function is called by Tcl_DoOneEvent to wait for new - * events on the message queue. If the block time is 0, then - * Tcl_WaitForEvent just polls without blocking. - * - * Results: - * Returns -1 if the select would block forever, otherwise - * returns 0. - * - * Side effects: - * Queues file events that are detected by the select. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_WaitForEvent(timePtr) - Tcl_Time *timePtr; /* Maximum block time, or NULL. */ -{ - FileHandler *filePtr; - FileHandlerEvent *fileEvPtr; - struct timeval timeout, *timeoutPtr; - int bit, index, mask; -#ifdef TCL_THREADS - int waitForFiles; -#else - int numFound; -#endif - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - - if (tclStubs.tcl_WaitForEvent != Tcl_WaitForEvent) { - return tclStubs.tcl_WaitForEvent(timePtr); - } - - /* - * Set up the timeout structure. Note that if there are no events to - * check for, we return with a negative result rather than blocking - * forever. - */ - - if (timePtr) { - timeout.tv_sec = timePtr->sec; - timeout.tv_usec = timePtr->usec; - timeoutPtr = &timeout; -#ifndef TCL_THREADS - } else if (tsdPtr->numFdBits == 0) { - /* - * If there are no threads, no timeout, and no fds registered, - * then there are no events possible and we must avoid deadlock. - * Note that this is not entirely correct because there might - * be a signal that could interrupt the select call, but we - * don't handle that case if we aren't using threads. - */ - - return -1; -#endif - } else { - timeoutPtr = NULL; - } - -#ifdef TCL_THREADS - /* - * Place this thread on the list of interested threads, signal the - * notifier thread, and wait for a response or a timeout. - */ - - Tcl_MutexLock(¬ifierMutex); - - waitForFiles = (tsdPtr->numFdBits > 0); - if (timePtr != NULL && timePtr->sec == 0 && timePtr->usec == 0) { - /* - * Cannot emulate a polling select with a polling condition variable. - * Instead, pretend to wait for files and tell the notifier - * thread what we are doing. The notifier thread makes sure - * it goes through select with its select mask in the same state - * as ours currently is. We block until that happens. - */ - - waitForFiles = 1; - tsdPtr->pollState = POLL_WANT; - timePtr = NULL; - } else { - tsdPtr->pollState = 0; - } - - if (waitForFiles) { - /* - * Add the ThreadSpecificData structure of this thread to the list - * of ThreadSpecificData structures of all threads that are waiting - * on file events. - */ - - - tsdPtr->nextPtr = waitingListPtr; - if (waitingListPtr) { - waitingListPtr->prevPtr = tsdPtr; - } - tsdPtr->prevPtr = 0; - waitingListPtr = tsdPtr; - tsdPtr->onList = 1; - - write(triggerPipe, "", 1); - } - - memset((VOID *) tsdPtr->readyMasks, 0, 3*MASK_SIZE*sizeof(fd_mask)); - - if (!tsdPtr->eventReady) { - Tcl_ConditionWait(&tsdPtr->waitCV, ¬ifierMutex, timePtr); - } - tsdPtr->eventReady = 0; - - if (waitForFiles && tsdPtr->onList) { - /* - * Remove the ThreadSpecificData structure of this thread from the - * waiting list. Alert the notifier thread to recompute its select - * masks - skipping this caused a hang when trying to close a pipe - * which the notifier thread was still doing a select on. - */ - - if (tsdPtr->prevPtr) { - tsdPtr->prevPtr->nextPtr = tsdPtr->nextPtr; - } else { - waitingListPtr = tsdPtr->nextPtr; - } - if (tsdPtr->nextPtr) { - tsdPtr->nextPtr->prevPtr = tsdPtr->prevPtr; - } - tsdPtr->nextPtr = tsdPtr->prevPtr = NULL; - tsdPtr->onList = 0; - write(triggerPipe, "", 1); - } - - -#else - memcpy((VOID *) tsdPtr->readyMasks, (VOID *) tsdPtr->checkMasks, - 3*MASK_SIZE*sizeof(fd_mask)); - numFound = select(tsdPtr->numFdBits, - (SELECT_MASK *) &tsdPtr->readyMasks[0], - (SELECT_MASK *) &tsdPtr->readyMasks[MASK_SIZE], - (SELECT_MASK *) &tsdPtr->readyMasks[2*MASK_SIZE], timeoutPtr); - - /* - * Some systems don't clear the masks after an error, so - * we have to do it here. - */ - - if (numFound == -1) { - memset((VOID *) tsdPtr->readyMasks, 0, 3*MASK_SIZE*sizeof(fd_mask)); - } -#endif - - /* - * Queue all detected file events before returning. - */ - - for (filePtr = tsdPtr->firstFileHandlerPtr; (filePtr != NULL); - filePtr = filePtr->nextPtr) { - index = filePtr->fd / (NBBY*sizeof(fd_mask)); - bit = 1 << (filePtr->fd % (NBBY*sizeof(fd_mask))); - mask = 0; - - if (tsdPtr->readyMasks[index] & bit) { - mask |= TCL_READABLE; - } - if ((tsdPtr->readyMasks+MASK_SIZE)[index] & bit) { - mask |= TCL_WRITABLE; - } - if ((tsdPtr->readyMasks+2*(MASK_SIZE))[index] & bit) { - mask |= TCL_EXCEPTION; - } - - if (!mask) { - continue; - } - - /* - * Don't bother to queue an event if the mask was previously - * non-zero since an event must still be on the queue. - */ - - if (filePtr->readyMask == 0) { - fileEvPtr = (FileHandlerEvent *) ckalloc( - sizeof(FileHandlerEvent)); - fileEvPtr->header.proc = FileHandlerEventProc; - fileEvPtr->fd = filePtr->fd; - Tcl_QueueEvent((Tcl_Event *) fileEvPtr, TCL_QUEUE_TAIL); - } - filePtr->readyMask = mask; - } -#ifdef TCL_THREADS - Tcl_MutexUnlock(¬ifierMutex); -#endif - return 0; -} - -#ifdef TCL_THREADS -/* - *---------------------------------------------------------------------- - * - * NotifierThreadProc -- - * - * This routine is the initial (and only) function executed by the - * special notifier thread. Its job is to wait for file descriptors - * to become readable or writable or to have an exception condition - * and then to notify other threads who are interested in this - * information by signalling a condition variable. Other threads - * can signal this notifier thread of a change in their interests - * by writing a single byte to a special pipe that the notifier - * thread is monitoring. - * - * Result: - * None. Once started, this routine never exits. It dies with - * the overall process. - * - * Side effects: - * The trigger pipe used to signal the notifier thread is created - * when the notifier thread first starts. - * - *---------------------------------------------------------------------- - */ - -static void -NotifierThreadProc(clientData) - ClientData clientData; /* Not used. */ -{ - ThreadSpecificData *tsdPtr; - fd_mask masks[3*MASK_SIZE]; - long *maskPtr = (long *)masks; /* masks[] cast to type long[] */ - int fds[2]; - int i, status, index, bit, numFdBits, found, receivePipe, word; - struct timeval poll = {0., 0.}, *timePtr; - int maskSize = 3 * ((MASK_SIZE) / sizeof(long)) * sizeof(fd_mask); - char buf[2]; - - if (pipe(fds) != 0) { - panic("NotifierThreadProc: could not create trigger pipe."); - } - - receivePipe = fds[0]; - -#ifndef USE_FIONBIO - status = fcntl(receivePipe, F_GETFL); - status |= O_NONBLOCK; - if (fcntl(receivePipe, F_SETFL, status) < 0) { - panic("NotifierThreadProc: could not make receive pipe non blocking."); - } - status = fcntl(fds[1], F_GETFL); - status |= O_NONBLOCK; - if (fcntl(fds[1], F_SETFL, status) < 0) { - panic("NotifierThreadProc: could not make trigger pipe non blocking."); - } -#else - if (ioctl(receivePipe, (int) FIONBIO, &status) < 0) { - panic("NotifierThreadProc: could not make receive pipe non blocking."); - } - if (ioctl(fds[1], (int) FIONBIO, &status) < 0) { - panic("NotifierThreadProc: could not make trigger pipe non blocking."); - } -#endif - - /* - * Install the write end of the pipe into the global variable. - */ - - Tcl_MutexLock(¬ifierMutex); - triggerPipe = fds[1]; - - /* - * Signal any threads that are waiting. - */ - - Tcl_ConditionNotify(¬ifierCV); - Tcl_MutexUnlock(¬ifierMutex); - - /* - * Look for file events and report them to interested threads. - */ - - while (1) { - /* - * Set up the select mask to include the receive pipe. - */ - - memset((VOID *)masks, 0, 3*MASK_SIZE*sizeof(fd_mask)); - numFdBits = receivePipe + 1; - index = receivePipe / (NBBY*sizeof(fd_mask)); - bit = 1 << (receivePipe % (NBBY*sizeof(fd_mask))); - masks[index] |= bit; - - /* - * Add in the check masks from all of the waiting notifiers. - */ - - Tcl_MutexLock(¬ifierMutex); - timePtr = NULL; - for (tsdPtr = waitingListPtr; tsdPtr; tsdPtr = tsdPtr->nextPtr) { - for (i = 0; i < maskSize; i++) { - maskPtr[i] |= ((long*)tsdPtr->checkMasks)[i]; - } - if (tsdPtr->numFdBits > numFdBits) { - numFdBits = tsdPtr->numFdBits; - } - if (tsdPtr->pollState & POLL_WANT) { - /* - * Here we make sure we go through select() with the same - * mask bits that were present when the thread tried to poll. - */ - - tsdPtr->pollState |= POLL_DONE; - timePtr = &poll; - } - } - Tcl_MutexUnlock(¬ifierMutex); - - maskSize = 3 * ((MASK_SIZE) / sizeof(long)) * sizeof(fd_mask); - - if (select(numFdBits, (SELECT_MASK *) &masks[0], - (SELECT_MASK *) &masks[MASK_SIZE], - (SELECT_MASK *) &masks[2*MASK_SIZE], timePtr) == -1) { - /* - * Try again immediately on an error. - */ - - continue; - } - - /* - * Alert any threads that are waiting on a ready file descriptor. - */ - - Tcl_MutexLock(¬ifierMutex); - for (tsdPtr = waitingListPtr; tsdPtr; tsdPtr = tsdPtr->nextPtr) { - found = 0; - - for (i = 0; i < maskSize; i++) { - word = maskPtr[i] & ((long*)tsdPtr->checkMasks)[i]; - found |= word; - (((long*)(tsdPtr->readyMasks))[i]) = word; - } - if (found || (tsdPtr->pollState & POLL_DONE)) { - tsdPtr->eventReady = 1; - Tcl_ConditionNotify(&tsdPtr->waitCV); - if (tsdPtr->onList) { - /* - * Remove the ThreadSpecificData structure of this - * thread from the waiting list. This prevents us from - * continuously spining on select until the other - * threads runs and services the file event. - */ - - if (tsdPtr->prevPtr) { - tsdPtr->prevPtr->nextPtr = tsdPtr->nextPtr; - } else { - waitingListPtr = tsdPtr->nextPtr; - } - if (tsdPtr->nextPtr) { - tsdPtr->nextPtr->prevPtr = tsdPtr->prevPtr; - } - tsdPtr->nextPtr = tsdPtr->prevPtr = NULL; - tsdPtr->onList = 0; - tsdPtr->pollState = 0; - } - } - } - Tcl_MutexUnlock(¬ifierMutex); - - /* - * Consume the next byte from the notifier pipe if the pipe was - * readable. Note that there may be multiple bytes pending, but - * to avoid a race condition we only read one at a time. - */ - - if (masks[index] & bit) { - i = read(receivePipe, buf, 1); - - if ((i == 0) || ((i == 1) && (buf[0] == 'q'))) { - /* - * Someone closed the write end of the pipe or sent us a - * Quit message [Bug: 4139] and then closed the write end - * of the pipe so we need to shut down the notifier thread. - */ - - break; - } - } - } - - /* - * Clean up the read end of the pipe and signal any threads waiting on - * termination of the notifier thread. - */ - - close(receivePipe); - Tcl_MutexLock(¬ifierMutex); - triggerPipe = -1; - Tcl_ConditionNotify(¬ifierCV); - Tcl_MutexUnlock(¬ifierMutex); -} -#endif diff --git a/unix/tclUnixPipe.c b/unix/tclUnixPipe.c deleted file mode 100644 index d234245..0000000 --- a/unix/tclUnixPipe.c +++ /dev/null @@ -1,1172 +0,0 @@ -/* - * tclUnixPipe.c -- - * - * This file implements the UNIX-specific exec pipeline functions, - * the "pipe" channel driver, and the "pid" Tcl command. - * - * Copyright (c) 1991-1994 The Regents of the University of California. - * Copyright (c) 1994-1997 Sun Microsystems, Inc. - * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclUnixPipe.c,v 1.9 2000/03/31 19:39:42 ericm Exp $ - */ - -#include "tclInt.h" -#include "tclPort.h" - -/* - * The following macros convert between TclFile's and fd's. The conversion - * simple involves shifting fd's up by one to ensure that no valid fd is ever - * the same as NULL. - */ - -#define MakeFile(fd) ((TclFile)(((int)fd)+1)) -#define GetFd(file) (((int)file)-1) - -/* - * This structure describes per-instance state of a pipe based channel. - */ - -typedef struct PipeState { - Tcl_Channel channel;/* Channel associated with this file. */ - TclFile inFile; /* Output from pipe. */ - TclFile outFile; /* Input to pipe. */ - TclFile errorFile; /* Error output from pipe. */ - int numPids; /* How many processes are attached to this pipe? */ - Tcl_Pid *pidPtr; /* The process IDs themselves. Allocated by - * the creator of the pipe. */ - int isNonBlocking; /* Nonzero when the pipe is in nonblocking mode. - * Used to decide whether to wait for the children - * at close time. */ -} PipeState; - -/* - * Declarations for local procedures defined in this file: - */ - -static int PipeBlockModeProc _ANSI_ARGS_((ClientData instanceData, - int mode)); -static int PipeCloseProc _ANSI_ARGS_((ClientData instanceData, - Tcl_Interp *interp)); -static int PipeGetHandleProc _ANSI_ARGS_((ClientData instanceData, - int direction, ClientData *handlePtr)); -static int PipeInputProc _ANSI_ARGS_((ClientData instanceData, - char *buf, int toRead, int *errorCode)); -static int PipeOutputProc _ANSI_ARGS_(( - ClientData instanceData, char *buf, int toWrite, - int *errorCode)); -static void PipeWatchProc _ANSI_ARGS_((ClientData instanceData, int mask)); -static void RestoreSignals _ANSI_ARGS_((void)); -static int SetupStdFile _ANSI_ARGS_((TclFile file, int type)); - -/* - * This structure describes the channel type structure for command pipe - * based IO: - */ - -static Tcl_ChannelType pipeChannelType = { - "pipe", /* Type name. */ - PipeBlockModeProc, /* Set blocking/nonblocking mode.*/ - PipeCloseProc, /* Close proc. */ - PipeInputProc, /* Input proc. */ - PipeOutputProc, /* Output proc. */ - NULL, /* Seek proc. */ - NULL, /* Set option proc. */ - NULL, /* Get option proc. */ - PipeWatchProc, /* Initialize notifier. */ - PipeGetHandleProc, /* Get OS handles out of channel. */ -}; - -/* - *---------------------------------------------------------------------- - * - * TclpMakeFile -- - * - * Make a TclFile from a channel. - * - * Results: - * Returns a new TclFile or NULL on failure. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -TclFile -TclpMakeFile(channel, direction) - Tcl_Channel channel; /* Channel to get file from. */ - int direction; /* Either TCL_READABLE or TCL_WRITABLE. */ -{ - ClientData data; - - if (Tcl_GetChannelHandle(channel, direction, (ClientData *) &data) - == TCL_OK) { - return MakeFile((int)data); - } else { - return (TclFile) NULL; - } -} - -/* - *---------------------------------------------------------------------- - * - * TclpOpenFile -- - * - * Open a file for use in a pipeline. - * - * Results: - * Returns a new TclFile handle or NULL on failure. - * - * Side effects: - * May cause a file to be created on the file system. - * - *---------------------------------------------------------------------- - */ - -TclFile -TclpOpenFile(fname, mode) - CONST char *fname; /* The name of the file to open. */ - int mode; /* In what mode to open the file? */ -{ - int fd; - char *native; - Tcl_DString ds; - - native = Tcl_UtfToExternalDString(NULL, fname, -1, &ds); - fd = open(native, mode, 0666); /* INTL: Native. */ - Tcl_DStringFree(&ds); - if (fd != -1) { - fcntl(fd, F_SETFD, FD_CLOEXEC); - - /* - * If the file is being opened for writing, seek to the end - * so we can append to any data already in the file. - */ - - if (mode & O_WRONLY) { - lseek(fd, (off_t) 0, SEEK_END); - } - - /* - * Increment the fd so it can't be 0, which would conflict with - * the NULL return for errors. - */ - - return MakeFile(fd); - } - return NULL; -} - -/* - *---------------------------------------------------------------------- - * - * TclpCreateTempFile -- - * - * This function creates a temporary file initialized with an - * optional string, and returns a file handle with the file pointer - * at the beginning of the file. - * - * Results: - * A handle to a file. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -TclFile -TclpCreateTempFile(contents) - CONST char *contents; /* String to write into temp file, or NULL. */ -{ - char fileName[L_tmpnam], *native; - Tcl_DString dstring; - int fd; - - if (tmpnam(fileName) == NULL) { /* INTL: Native. */ - return NULL; - } - fd = open(fileName, O_RDWR|O_CREAT|O_TRUNC, 0666); /* INTL: Native. */ - if (fd == -1) { - return NULL; - } - fcntl(fd, F_SETFD, FD_CLOEXEC); - unlink(fileName); /* INTL: Native. */ - - if (contents != NULL) { - native = Tcl_UtfToExternalDString(NULL, contents, -1, &dstring); - if (write(fd, native, strlen(native)) == -1) { - close(fd); - Tcl_DStringFree(&dstring); - return NULL; - } - Tcl_DStringFree(&dstring); - lseek(fd, (off_t) 0, SEEK_SET); - } - return MakeFile(fd); -} - -/* - *---------------------------------------------------------------------- - * - * TclpCreatePipe -- - * - * Creates a pipe - simply calls the pipe() function. - * - * Results: - * Returns 1 on success, 0 on failure. - * - * Side effects: - * Creates a pipe. - * - *---------------------------------------------------------------------- - */ - -int -TclpCreatePipe(readPipe, writePipe) - TclFile *readPipe; /* Location to store file handle for - * read side of pipe. */ - TclFile *writePipe; /* Location to store file handle for - * write side of pipe. */ -{ - int pipeIds[2]; - - if (pipe(pipeIds) != 0) { - return 0; - } - - fcntl(pipeIds[0], F_SETFD, FD_CLOEXEC); - fcntl(pipeIds[1], F_SETFD, FD_CLOEXEC); - - *readPipe = MakeFile(pipeIds[0]); - *writePipe = MakeFile(pipeIds[1]); - return 1; -} - -/* - *---------------------------------------------------------------------- - * - * TclpCloseFile -- - * - * Implements a mechanism to close a UNIX file. - * - * Results: - * Returns 0 on success, or -1 on error, setting errno. - * - * Side effects: - * The file is closed. - * - *---------------------------------------------------------------------- - */ - -int -TclpCloseFile(file) - TclFile file; /* The file to close. */ -{ - int fd = GetFd(file); - - /* - * Refuse to close the fds for stdin, stdout and stderr. - */ - - if ((fd == 0) || (fd == 1) || (fd == 2)) { - return 0; - } - - Tcl_DeleteFileHandler(fd); - return close(fd); -} - -/* - *--------------------------------------------------------------------------- - * - * TclpCreateProcess -- - * - * Create a child process that has the specified files as its - * standard input, output, and error. The child process runs - * asynchronously and runs with the same environment variables - * as the creating process. - * - * The path is searched to find the specified executable. - * - * Results: - * The return value is TCL_ERROR and an error message is left in - * the interp's result if there was a problem creating the child - * process. Otherwise, the return value is TCL_OK and *pidPtr is - * filled with the process id of the child process. - * - * Side effects: - * A process is created. - * - *--------------------------------------------------------------------------- - */ - - /* ARGSUSED */ -int -TclpCreateProcess(interp, argc, argv, inputFile, outputFile, errorFile, - pidPtr) - Tcl_Interp *interp; /* Interpreter in which to leave errors that - * occurred when creating the child process. - * Error messages from the child process - * itself are sent to errorFile. */ - int argc; /* Number of arguments in following array. */ - char **argv; /* Array of argument strings in UTF-8. - * argv[0] contains the name of the executable - * translated using Tcl_TranslateFileName - * call). Additional arguments have not been - * converted. */ - TclFile inputFile; /* If non-NULL, gives the file to use as - * input for the child process. If inputFile - * file is not readable or is NULL, the child - * will receive no standard input. */ - TclFile outputFile; /* If non-NULL, gives the file that - * receives output from the child process. If - * outputFile file is not writeable or is - * NULL, output from the child will be - * discarded. */ - TclFile errorFile; /* If non-NULL, gives the file that - * receives errors from the child process. If - * errorFile file is not writeable or is NULL, - * errors from the child will be discarded. - * errorFile may be the same as outputFile. */ - Tcl_Pid *pidPtr; /* If this procedure is successful, pidPtr - * is filled with the process id of the child - * process. */ -{ - TclFile errPipeIn, errPipeOut; - int joinThisError, count, status, fd; - char errSpace[200 + TCL_INTEGER_SPACE]; - Tcl_DString *dsArray; - char **newArgv; - int pid, i; - - errPipeIn = NULL; - errPipeOut = NULL; - pid = -1; - - /* - * Create a pipe that the child can use to return error - * information if anything goes wrong. - */ - - if (TclpCreatePipe(&errPipeIn, &errPipeOut) == 0) { - Tcl_AppendResult(interp, "couldn't create pipe: ", - Tcl_PosixError(interp), (char *) NULL); - goto error; - } - - /* - * We need to allocate and convert this before the fork - * so it is properly deallocated later - */ - dsArray = (Tcl_DString *) ckalloc(argc * sizeof(Tcl_DString)); - newArgv = (char **) ckalloc((argc+1) * sizeof(char *)); - newArgv[argc] = NULL; - for (i = 0; i < argc; i++) { - newArgv[i] = Tcl_UtfToExternalDString(NULL, argv[i], -1, &dsArray[i]); - } - - joinThisError = (errorFile == outputFile); - pid = fork(); - if (pid == 0) { - fd = GetFd(errPipeOut); - - /* - * Set up stdio file handles for the child process. - */ - - if (!SetupStdFile(inputFile, TCL_STDIN) - || !SetupStdFile(outputFile, TCL_STDOUT) - || (!joinThisError && !SetupStdFile(errorFile, TCL_STDERR)) - || (joinThisError && - ((dup2(1,2) == -1) || - (fcntl(2, F_SETFD, 0) != 0)))) { - sprintf(errSpace, - "%dforked process couldn't set up input/output: ", errno); - write(fd, errSpace, (size_t) strlen(errSpace)); - _exit(1); - } - - /* - * Close the input side of the error pipe. - */ - - RestoreSignals(); - execvp(newArgv[0], newArgv); /* INTL: Native. */ - sprintf(errSpace, "%dcouldn't execute \"%.150s\": ", errno, argv[0]); - write(fd, errSpace, (size_t) strlen(errSpace)); - _exit(1); - } - - /* - * Free the mem we used for the fork - */ - for (i = 0; i < argc; i++) { - Tcl_DStringFree(&dsArray[i]); - } - ckfree((char *) dsArray); - ckfree((char *) newArgv); - - if (pid == -1) { - Tcl_AppendResult(interp, "couldn't fork child process: ", - Tcl_PosixError(interp), (char *) NULL); - goto error; - } - - /* - * Read back from the error pipe to see if the child started - * up OK. The info in the pipe (if any) consists of a decimal - * errno value followed by an error message. - */ - - TclpCloseFile(errPipeOut); - errPipeOut = NULL; - - fd = GetFd(errPipeIn); - count = read(fd, errSpace, (size_t) (sizeof(errSpace) - 1)); - if (count > 0) { - char *end; - errSpace[count] = 0; - errno = strtol(errSpace, &end, 10); - Tcl_AppendResult(interp, end, Tcl_PosixError(interp), - (char *) NULL); - goto error; - } - - TclpCloseFile(errPipeIn); - *pidPtr = (Tcl_Pid) pid; - return TCL_OK; - - error: - if (pid != -1) { - /* - * Reap the child process now if an error occurred during its - * startup. - */ - - Tcl_WaitPid((Tcl_Pid) pid, &status, WNOHANG); - } - - if (errPipeIn) { - TclpCloseFile(errPipeIn); - } - if (errPipeOut) { - TclpCloseFile(errPipeOut); - } - return TCL_ERROR; -} - -/* - *---------------------------------------------------------------------- - * - * RestoreSignals -- - * - * This procedure is invoked in a forked child process just before - * exec-ing a new program to restore all signals to their default - * settings. - * - * Results: - * None. - * - * Side effects: - * Signal settings get changed. - * - *---------------------------------------------------------------------- - */ - -static void -RestoreSignals() -{ -#ifdef SIGABRT - signal(SIGABRT, SIG_DFL); -#endif -#ifdef SIGALRM - signal(SIGALRM, SIG_DFL); -#endif -#ifdef SIGFPE - signal(SIGFPE, SIG_DFL); -#endif -#ifdef SIGHUP - signal(SIGHUP, SIG_DFL); -#endif -#ifdef SIGILL - signal(SIGILL, SIG_DFL); -#endif -#ifdef SIGINT - signal(SIGINT, SIG_DFL); -#endif -#ifdef SIGPIPE - signal(SIGPIPE, SIG_DFL); -#endif -#ifdef SIGQUIT - signal(SIGQUIT, SIG_DFL); -#endif -#ifdef SIGSEGV - signal(SIGSEGV, SIG_DFL); -#endif -#ifdef SIGTERM - signal(SIGTERM, SIG_DFL); -#endif -#ifdef SIGUSR1 - signal(SIGUSR1, SIG_DFL); -#endif -#ifdef SIGUSR2 - signal(SIGUSR2, SIG_DFL); -#endif -#ifdef SIGCHLD - signal(SIGCHLD, SIG_DFL); -#endif -#ifdef SIGCONT - signal(SIGCONT, SIG_DFL); -#endif -#ifdef SIGTSTP - signal(SIGTSTP, SIG_DFL); -#endif -#ifdef SIGTTIN - signal(SIGTTIN, SIG_DFL); -#endif -#ifdef SIGTTOU - signal(SIGTTOU, SIG_DFL); -#endif -} - -/* - *---------------------------------------------------------------------- - * - * SetupStdFile -- - * - * Set up stdio file handles for the child process, using the - * current standard channels if no other files are specified. - * If no standard channel is defined, or if no file is associated - * with the channel, then the corresponding standard fd is closed. - * - * Results: - * Returns 1 on success, or 0 on failure. - * - * Side effects: - * Replaces stdio fds. - * - *---------------------------------------------------------------------- - */ - -static int -SetupStdFile(file, type) - TclFile file; /* File to dup, or NULL. */ - int type; /* One of TCL_STDIN, TCL_STDOUT, TCL_STDERR */ -{ - Tcl_Channel channel; - int fd; - int targetFd = 0; /* Initializations here needed only to */ - int direction = 0; /* prevent warnings about using uninitialized - * variables. */ - - switch (type) { - case TCL_STDIN: - targetFd = 0; - direction = TCL_READABLE; - break; - case TCL_STDOUT: - targetFd = 1; - direction = TCL_WRITABLE; - break; - case TCL_STDERR: - targetFd = 2; - direction = TCL_WRITABLE; - break; - } - - if (!file) { - channel = Tcl_GetStdChannel(type); - if (channel) { - file = TclpMakeFile(channel, direction); - } - } - if (file) { - fd = GetFd(file); - if (fd != targetFd) { - if (dup2(fd, targetFd) == -1) { - return 0; - } - - /* - * Must clear the close-on-exec flag for the target FD, since - * some systems (e.g. Ultrix) do not clear the CLOEXEC flag on - * the target FD. - */ - - fcntl(targetFd, F_SETFD, 0); - } else { - int result; - - /* - * Since we aren't dup'ing the file, we need to explicitly clear - * the close-on-exec flag. - */ - - result = fcntl(fd, F_SETFD, 0); - } - } else { - close(targetFd); - } - return 1; -} - -/* - *---------------------------------------------------------------------- - * - * TclpCreateCommandChannel -- - * - * This function is called by the generic IO level to perform - * the platform specific channel initialization for a command - * channel. - * - * Results: - * Returns a new channel or NULL on failure. - * - * Side effects: - * Allocates a new channel. - * - *---------------------------------------------------------------------- - */ - -Tcl_Channel -TclpCreateCommandChannel(readFile, writeFile, errorFile, numPids, pidPtr) - TclFile readFile; /* If non-null, gives the file for reading. */ - TclFile writeFile; /* If non-null, gives the file for writing. */ - TclFile errorFile; /* If non-null, gives the file where errors - * can be read. */ - int numPids; /* The number of pids in the pid array. */ - Tcl_Pid *pidPtr; /* An array of process identifiers. - * Allocated by the caller, freed when - * the channel is closed or the processes - * are detached (in a background exec). */ -{ - char channelName[16 + TCL_INTEGER_SPACE]; - int channelId; - PipeState *statePtr = (PipeState *) ckalloc((unsigned) sizeof(PipeState)); - int mode; - - statePtr->inFile = readFile; - statePtr->outFile = writeFile; - statePtr->errorFile = errorFile; - statePtr->numPids = numPids; - statePtr->pidPtr = pidPtr; - statePtr->isNonBlocking = 0; - - mode = 0; - if (readFile) { - mode |= TCL_READABLE; - } - if (writeFile) { - mode |= TCL_WRITABLE; - } - - /* - * Use one of the fds associated with the channel as the - * channel id. - */ - - if (readFile) { - channelId = GetFd(readFile); - } else if (writeFile) { - channelId = GetFd(writeFile); - } else if (errorFile) { - channelId = GetFd(errorFile); - } else { - channelId = 0; - } - - /* - * For backward compatibility with previous versions of Tcl, we - * use "file%d" as the base name for pipes even though it would - * be more natural to use "pipe%d". - */ - - sprintf(channelName, "file%d", channelId); - statePtr->channel = Tcl_CreateChannel(&pipeChannelType, channelName, - (ClientData) statePtr, mode); - return statePtr->channel; -} - -/* - *---------------------------------------------------------------------- - * - * TclGetAndDetachPids -- - * - * This procedure is invoked in the generic implementation of a - * background "exec" (An exec when invoked with a terminating "&") - * to store a list of the PIDs for processes in a command pipeline - * in the interp's result and to detach the processes. - * - * Results: - * None. - * - * Side effects: - * Modifies the interp's result. Detaches processes. - * - *---------------------------------------------------------------------- - */ - -void -TclGetAndDetachPids(interp, chan) - Tcl_Interp *interp; - Tcl_Channel chan; -{ - PipeState *pipePtr; - Tcl_ChannelType *chanTypePtr; - int i; - char buf[TCL_INTEGER_SPACE]; - - /* - * Punt if the channel is not a command channel. - */ - - chanTypePtr = Tcl_GetChannelType(chan); - if (chanTypePtr != &pipeChannelType) { - return; - } - - pipePtr = (PipeState *) Tcl_GetChannelInstanceData(chan); - for (i = 0; i < pipePtr->numPids; i++) { - TclFormatInt(buf, (long) TclpGetPid(pipePtr->pidPtr[i])); - Tcl_AppendElement(interp, buf); - Tcl_DetachPids(1, &(pipePtr->pidPtr[i])); - } - if (pipePtr->numPids > 0) { - ckfree((char *) pipePtr->pidPtr); - pipePtr->numPids = 0; - } -} - -/* - *---------------------------------------------------------------------- - * - * PipeBlockModeProc -- - * - * Helper procedure to set blocking and nonblocking modes on a - * pipe based channel. Invoked by generic IO level code. - * - * Results: - * 0 if successful, errno when failed. - * - * Side effects: - * Sets the device into blocking or non-blocking mode. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -static int -PipeBlockModeProc(instanceData, mode) - ClientData instanceData; /* Pipe state. */ - int mode; /* The mode to set. Can be one of - * TCL_MODE_BLOCKING or - * TCL_MODE_NONBLOCKING. */ -{ - PipeState *psPtr = (PipeState *) instanceData; - int curStatus; - int fd; - -#ifndef USE_FIONBIO - if (psPtr->inFile) { - fd = GetFd(psPtr->inFile); - curStatus = fcntl(fd, F_GETFL); - if (mode == TCL_MODE_BLOCKING) { - curStatus &= (~(O_NONBLOCK)); - } else { - curStatus |= O_NONBLOCK; - } - if (fcntl(fd, F_SETFL, curStatus) < 0) { - return errno; - } - } - if (psPtr->outFile) { - fd = GetFd(psPtr->outFile); - curStatus = fcntl(fd, F_GETFL); - if (mode == TCL_MODE_BLOCKING) { - curStatus &= (~(O_NONBLOCK)); - } else { - curStatus |= O_NONBLOCK; - } - if (fcntl(fd, F_SETFL, curStatus) < 0) { - return errno; - } - } -#endif /* !FIONBIO */ - -#ifdef USE_FIONBIO - if (psPtr->inFile) { - fd = GetFd(psPtr->inFile); - if (mode == TCL_MODE_BLOCKING) { - curStatus = 0; - } else { - curStatus = 1; - } - if (ioctl(fd, (int) FIONBIO, &curStatus) < 0) { - return errno; - } - } - if (psPtr->outFile != NULL) { - fd = GetFd(psPtr->outFile); - if (mode == TCL_MODE_BLOCKING) { - curStatus = 0; - } else { - curStatus = 1; - } - if (ioctl(fd, (int) FIONBIO, &curStatus) < 0) { - return errno; - } - } -#endif /* USE_FIONBIO */ - - psPtr->isNonBlocking = (mode == TCL_MODE_NONBLOCKING); - - return 0; -} - -/* - *---------------------------------------------------------------------- - * - * PipeCloseProc -- - * - * This procedure is invoked by the generic IO level to perform - * channel-type-specific cleanup when a command pipeline channel - * is closed. - * - * Results: - * 0 on success, errno otherwise. - * - * Side effects: - * Closes the command pipeline channel. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -static int -PipeCloseProc(instanceData, interp) - ClientData instanceData; /* The pipe to close. */ - Tcl_Interp *interp; /* For error reporting. */ -{ - PipeState *pipePtr; - Tcl_Channel errChan; - int errorCode, result; - - errorCode = 0; - result = 0; - pipePtr = (PipeState *) instanceData; - if (pipePtr->inFile) { - if (TclpCloseFile(pipePtr->inFile) < 0) { - errorCode = errno; - } - } - if (pipePtr->outFile) { - if ((TclpCloseFile(pipePtr->outFile) < 0) && (errorCode == 0)) { - errorCode = errno; - } - } - - if (pipePtr->isNonBlocking || TclInExit()) { - - /* - * If the channel is non-blocking or Tcl is being cleaned up, just - * detach the children PIDs, reap them (important if we are in a - * dynamic load module), and discard the errorFile. - */ - - Tcl_DetachPids(pipePtr->numPids, pipePtr->pidPtr); - Tcl_ReapDetachedProcs(); - - if (pipePtr->errorFile) { - TclpCloseFile(pipePtr->errorFile); - } - } else { - - /* - * Wrap the error file into a channel and give it to the cleanup - * routine. - */ - - if (pipePtr->errorFile) { - errChan = Tcl_MakeFileChannel( - (ClientData) GetFd(pipePtr->errorFile), TCL_READABLE); - } else { - errChan = NULL; - } - result = TclCleanupChildren(interp, pipePtr->numPids, pipePtr->pidPtr, - errChan); - } - - if (pipePtr->numPids != 0) { - ckfree((char *) pipePtr->pidPtr); - } - ckfree((char *) pipePtr); - if (errorCode == 0) { - return result; - } - return errorCode; -} - -/* - *---------------------------------------------------------------------- - * - * PipeInputProc -- - * - * This procedure is invoked from the generic IO level to read - * input from a command pipeline based channel. - * - * Results: - * The number of bytes read is returned or -1 on error. An output - * argument contains a POSIX error code if an error occurs, or zero. - * - * Side effects: - * Reads input from the input device of the channel. - * - *---------------------------------------------------------------------- - */ - -static int -PipeInputProc(instanceData, buf, toRead, errorCodePtr) - ClientData instanceData; /* Pipe state. */ - char *buf; /* Where to store data read. */ - int toRead; /* How much space is available - * in the buffer? */ - int *errorCodePtr; /* Where to store error code. */ -{ - PipeState *psPtr = (PipeState *) instanceData; - int bytesRead; /* How many bytes were actually - * read from the input device? */ - - *errorCodePtr = 0; - - /* - * Assume there is always enough input available. This will block - * appropriately, and read will unblock as soon as a short read is - * possible, if the channel is in blocking mode. If the channel is - * nonblocking, the read will never block. - */ - - bytesRead = read(GetFd(psPtr->inFile), buf, (size_t) toRead); - if (bytesRead > -1) { - return bytesRead; - } - *errorCodePtr = errno; - return -1; -} - -/* - *---------------------------------------------------------------------- - * - * PipeOutputProc-- - * - * This procedure is invoked from the generic IO level to write - * output to a command pipeline based channel. - * - * Results: - * The number of bytes written is returned or -1 on error. An - * output argument contains a POSIX error code if an error occurred, - * or zero. - * - * Side effects: - * Writes output on the output device of the channel. - * - *---------------------------------------------------------------------- - */ - -static int -PipeOutputProc(instanceData, buf, toWrite, errorCodePtr) - ClientData instanceData; /* Pipe state. */ - char *buf; /* The data buffer. */ - int toWrite; /* How many bytes to write? */ - int *errorCodePtr; /* Where to store error code. */ -{ - PipeState *psPtr = (PipeState *) instanceData; - int written; - - *errorCodePtr = 0; - written = write(GetFd(psPtr->outFile), buf, (size_t) toWrite); - if (written > -1) { - return written; - } - *errorCodePtr = errno; - return -1; -} - -/* - *---------------------------------------------------------------------- - * - * PipeWatchProc -- - * - * Initialize the notifier to watch the fds from this channel. - * - * Results: - * None. - * - * Side effects: - * Sets up the notifier so that a future event on the channel will - * be seen by Tcl. - * - *---------------------------------------------------------------------- - */ - -static void -PipeWatchProc(instanceData, mask) - ClientData instanceData; /* The pipe state. */ - int mask; /* Events of interest; an OR-ed - * combination of TCL_READABLE, - * TCL_WRITABEL and TCL_EXCEPTION. */ -{ - PipeState *psPtr = (PipeState *) instanceData; - int newmask; - - if (psPtr->inFile) { - newmask = mask & (TCL_READABLE | TCL_EXCEPTION); - if (newmask) { - Tcl_CreateFileHandler(GetFd(psPtr->inFile), mask, - (Tcl_FileProc *) Tcl_NotifyChannel, - (ClientData) psPtr->channel); - } else { - Tcl_DeleteFileHandler(GetFd(psPtr->inFile)); - } - } - if (psPtr->outFile) { - newmask = mask & (TCL_WRITABLE | TCL_EXCEPTION); - if (newmask) { - Tcl_CreateFileHandler(GetFd(psPtr->outFile), mask, - (Tcl_FileProc *) Tcl_NotifyChannel, - (ClientData) psPtr->channel); - } else { - Tcl_DeleteFileHandler(GetFd(psPtr->outFile)); - } - } -} - -/* - *---------------------------------------------------------------------- - * - * PipeGetHandleProc -- - * - * Called from Tcl_GetChannelHandle to retrieve OS handles from - * inside a command pipeline based channel. - * - * Results: - * Returns TCL_OK with the fd in handlePtr, or TCL_ERROR if - * there is no handle for the specified direction. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -PipeGetHandleProc(instanceData, direction, handlePtr) - ClientData instanceData; /* The pipe state. */ - int direction; /* TCL_READABLE or TCL_WRITABLE */ - ClientData *handlePtr; /* Where to store the handle. */ -{ - PipeState *psPtr = (PipeState *) instanceData; - - if (direction == TCL_READABLE && psPtr->inFile) { - *handlePtr = (ClientData) GetFd(psPtr->inFile); - return TCL_OK; - } - if (direction == TCL_WRITABLE && psPtr->outFile) { - *handlePtr = (ClientData) GetFd(psPtr->outFile); - return TCL_OK; - } - return TCL_ERROR; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_WaitPid -- - * - * Implements the waitpid system call on Unix systems. - * - * Results: - * Result of calling waitpid. - * - * Side effects: - * Waits for a process to terminate. - * - *---------------------------------------------------------------------- - */ - -Tcl_Pid -Tcl_WaitPid(pid, statPtr, options) - Tcl_Pid pid; - int *statPtr; - int options; -{ - int result; - pid_t real_pid; - - real_pid = (pid_t) pid; - while (1) { - result = (int) waitpid(real_pid, statPtr, options); - if ((result != -1) || (errno != EINTR)) { - return (Tcl_Pid) result; - } - } -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_PidObjCmd -- - * - * This procedure is invoked to process the "pid" Tcl command. - * See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -int -Tcl_PidObjCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST *objv; /* Argument strings. */ -{ - Tcl_Channel chan; - Tcl_ChannelType *chanTypePtr; - PipeState *pipePtr; - int i; - Tcl_Obj *resultPtr, *longObjPtr; - - if (objc > 2) { - Tcl_WrongNumArgs(interp, 1, objv, "?channelId?"); - return TCL_ERROR; - } - if (objc == 1) { - Tcl_SetLongObj(Tcl_GetObjResult(interp), (long) getpid()); - } else { - chan = Tcl_GetChannel(interp, Tcl_GetString(objv[1]), NULL); - if (chan == (Tcl_Channel) NULL) { - return TCL_ERROR; - } - chanTypePtr = Tcl_GetChannelType(chan); - if (chanTypePtr != &pipeChannelType) { - return TCL_OK; - } - pipePtr = (PipeState *) Tcl_GetChannelInstanceData(chan); - resultPtr = Tcl_GetObjResult(interp); - for (i = 0; i < pipePtr->numPids; i++) { - longObjPtr = Tcl_NewLongObj((long) TclpGetPid(pipePtr->pidPtr[i])); - Tcl_ListObjAppendElement(NULL, resultPtr, longObjPtr); - } - } - return TCL_OK; -} diff --git a/unix/tclUnixPort.h b/unix/tclUnixPort.h deleted file mode 100644 index cb3c777..0000000 --- a/unix/tclUnixPort.h +++ /dev/null @@ -1,514 +0,0 @@ -/* - * tclUnixPort.h -- - * - * This header file handles porting issues that occur because - * of differences between systems. It reads in UNIX-related - * header files and sets up UNIX-related macros for Tcl's UNIX - * core. It should be the only file that contains #ifdefs to - * handle different flavors of UNIX. This file sets up the - * union of all UNIX-related things needed by any of the Tcl - * core files. This file depends on configuration #defines such - * as NO_DIRENT_H that are set up by the "configure" script. - * - * Much of the material in this file was originally contributed - * by Karl Lehenbauer, Mark Diekhans and Peter da Silva. - * - * Copyright (c) 1991-1994 The Regents of the University of California. - * Copyright (c) 1994-1997 Sun Microsystems, Inc. - * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclUnixPort.h,v 1.15 2000/04/21 04:04:12 hobbs Exp $ - */ - -#ifndef _TCLUNIXPORT -#define _TCLUNIXPORT - -#ifndef _TCLINT -# include "tclInt.h" -#endif - -/* - *--------------------------------------------------------------------------- - * The following sets of #includes and #ifdefs are required to get Tcl to - * compile under the various flavors of unix. - *--------------------------------------------------------------------------- - */ - -#include <errno.h> -#include <fcntl.h> -#ifdef HAVE_NET_ERRNO_H -# include <net/errno.h> -#endif -#include <pwd.h> -#include <signal.h> -#ifdef HAVE_SYS_PARAM_H -# include <sys/param.h> -#endif -#include <sys/types.h> -#ifdef USE_DIRENT2_H -# include "../compat/dirent2.h" -#else -#ifdef NO_DIRENT_H -# include "../compat/dirent.h" -#else -# include <dirent.h> -#endif -#endif -#include <sys/file.h> -#ifdef HAVE_SYS_SELECT_H -# include <sys/select.h> -#endif -#include <sys/stat.h> -#if TIME_WITH_SYS_TIME -# include <sys/time.h> -# include <time.h> -#else -#if HAVE_SYS_TIME_H -# include <sys/time.h> -#else -# include <time.h> -#endif -#endif -#ifndef NO_SYS_WAIT_H -# include <sys/wait.h> -#endif -#ifdef HAVE_UNISTD_H -# include <unistd.h> -#else -# include "../compat/unistd.h" -#endif -#ifdef USE_FIONBIO - /* - * Not using the Posix fcntl(...,O_NONBLOCK,...) interface, instead - * we are using ioctl(..,FIONBIO,..). - */ - -# ifdef HAVE_SYS_FILIO_H -# include <sys/filio.h> /* For FIONBIO. */ -# endif - -# ifdef HAVE_SYS_IOCTL_H -# include <sys/ioctl.h> /* For FIONBIO. */ -# endif -#endif /* USE_FIONBIO */ -#include <utime.h> - -/* - * Socket support stuff: This likely needs more work to parameterize for - * each system. - */ - -#include <sys/socket.h> /* struct sockaddr, SOCK_STREAM, ... */ -#ifndef NO_UNAME -# include <sys/utsname.h> /* uname system call. */ -#endif -#include <netinet/in.h> /* struct in_addr, struct sockaddr_in */ -#include <arpa/inet.h> /* inet_ntoa() */ -#include <netdb.h> /* gethostbyname() */ - -/* - * Some platforms (e.g. SunOS) don't define FLT_MAX and FLT_MIN, so we - * look for an alternative definition. If no other alternative is available - * we use a reasonable guess. - */ - -#ifndef NO_FLOAT_H -# include <float.h> -#else -#ifndef NO_VALUES_H -# include <values.h> -#endif -#endif - -#ifndef FLT_MAX -# ifdef MAXFLOAT -# define FLT_MAX MAXFLOAT -# else -# define FLT_MAX 3.402823466E+38F -# endif -#endif -#ifndef FLT_MIN -# ifdef MINFLOAT -# define FLT_MIN MINFLOAT -# else -# define FLT_MIN 1.175494351E-38F -# endif -#endif - -/* - * NeXT doesn't define O_NONBLOCK, so #define it here if necessary. - */ - -#ifndef O_NONBLOCK -# define O_NONBLOCK 0x80 -#endif - -/* - * HPUX needs the flag O_NONBLOCK to get the right non-blocking I/O - * semantics, while most other systems need O_NDELAY. Define the - * constant NBIO_FLAG to be one of these - */ - -#ifdef HPUX -# define NBIO_FLAG O_NONBLOCK -#else -# define NBIO_FLAG O_NDELAY -#endif - -/* - * The type of the status returned by wait varies from UNIX system - * to UNIX system. The macro below defines it: - */ - -#ifdef _AIX -# define WAIT_STATUS_TYPE pid_t -#else -#ifndef NO_UNION_WAIT -# define WAIT_STATUS_TYPE union wait -#else -# define WAIT_STATUS_TYPE int -#endif -#endif - -/* - * Supply definitions for macros to query wait status, if not already - * defined in header files above. - */ - -#ifndef WIFEXITED -# define WIFEXITED(stat) (((*((int *) &(stat))) & 0xff) == 0) -#endif - -#ifndef WEXITSTATUS -# define WEXITSTATUS(stat) (((*((int *) &(stat))) >> 8) & 0xff) -#endif - -#ifndef WIFSIGNALED -# define WIFSIGNALED(stat) (((*((int *) &(stat)))) && ((*((int *) &(stat))) == ((*((int *) &(stat))) & 0x00ff))) -#endif - -#ifndef WTERMSIG -# define WTERMSIG(stat) ((*((int *) &(stat))) & 0x7f) -#endif - -#ifndef WIFSTOPPED -# define WIFSTOPPED(stat) (((*((int *) &(stat))) & 0xff) == 0177) -#endif - -#ifndef WSTOPSIG -# define WSTOPSIG(stat) (((*((int *) &(stat))) >> 8) & 0xff) -#endif - -/* - * Define constants for waitpid() system call if they aren't defined - * by a system header file. - */ - -#ifndef WNOHANG -# define WNOHANG 1 -#endif -#ifndef WUNTRACED -# define WUNTRACED 2 -#endif - -/* - * Supply macros for seek offsets, if they're not already provided by - * an include file. - */ - -#ifndef SEEK_SET -# define SEEK_SET 0 -#endif -#ifndef SEEK_CUR -# define SEEK_CUR 1 -#endif -#ifndef SEEK_END -# define SEEK_END 2 -#endif - -/* - * The stuff below is needed by the "time" command. If this system has no - * gettimeofday call, then must use times and the CLK_TCK #define (from - * sys/param.h) to compute elapsed time. Unfortunately, some systems only - * have HZ and no CLK_TCK, and some might not even have HZ. - */ - -#ifdef NO_GETTOD -# include <sys/times.h> -# include <sys/param.h> -# ifndef CLK_TCK -# ifdef HZ -# define CLK_TCK HZ -# else -# define CLK_TCK 60 -# endif -# endif -#else -# ifdef HAVE_BSDGETTIMEOFDAY -# define gettimeofday BSDgettimeofday -# endif -#endif - -#ifdef GETTOD_NOT_DECLARED -EXTERN int gettimeofday _ANSI_ARGS_((struct timeval *tp, - struct timezone *tzp)); -#endif - -/* - * Define access mode constants if they aren't already defined. - */ - -#ifndef F_OK -# define F_OK 00 -#endif -#ifndef X_OK -# define X_OK 01 -#endif -#ifndef W_OK -# define W_OK 02 -#endif -#ifndef R_OK -# define R_OK 04 -#endif - -/* - * Define FD_CLOEEXEC (the close-on-exec flag bit) if it isn't - * already defined. - */ - -#ifndef FD_CLOEXEC -# define FD_CLOEXEC 1 -#endif - -/* - * On systems without symbolic links (i.e. S_IFLNK isn't defined) - * define "lstat" to use "stat" instead. - */ - -#ifndef S_IFLNK -# define lstat stat -#endif - -/* - * Define macros to query file type bits, if they're not already - * defined. - */ - -#ifndef S_ISREG -# ifdef S_IFREG -# define S_ISREG(m) (((m) & S_IFMT) == S_IFREG) -# else -# define S_ISREG(m) 0 -# endif -# endif -#ifndef S_ISDIR -# ifdef S_IFDIR -# define S_ISDIR(m) (((m) & S_IFMT) == S_IFDIR) -# else -# define S_ISDIR(m) 0 -# endif -# endif -#ifndef S_ISCHR -# ifdef S_IFCHR -# define S_ISCHR(m) (((m) & S_IFMT) == S_IFCHR) -# else -# define S_ISCHR(m) 0 -# endif -# endif -#ifndef S_ISBLK -# ifdef S_IFBLK -# define S_ISBLK(m) (((m) & S_IFMT) == S_IFBLK) -# else -# define S_ISBLK(m) 0 -# endif -# endif -#ifndef S_ISFIFO -# ifdef S_IFIFO -# define S_ISFIFO(m) (((m) & S_IFMT) == S_IFIFO) -# else -# define S_ISFIFO(m) 0 -# endif -# endif -#ifndef S_ISLNK -# ifdef S_IFLNK -# define S_ISLNK(m) (((m) & S_IFMT) == S_IFLNK) -# else -# define S_ISLNK(m) 0 -# endif -# endif -#ifndef S_ISSOCK -# ifdef S_IFSOCK -# define S_ISSOCK(m) (((m) & S_IFMT) == S_IFSOCK) -# else -# define S_ISSOCK(m) 0 -# endif -# endif - -/* - * Make sure that MAXPATHLEN is defined. - */ - -#ifndef MAXPATHLEN -# ifdef PATH_MAX -# define MAXPATHLEN PATH_MAX -# else -# define MAXPATHLEN 2048 -# endif -#endif - -/* - * Make sure that L_tmpnam is defined. - */ - -#ifndef L_tmpnam -# define L_tmpnam 100 -#endif - -/* - * The following macro defines the type of the mask arguments to - * select: - */ - -#ifndef NO_FD_SET -# define SELECT_MASK fd_set -#else -# ifndef _AIX - typedef long fd_mask; -# endif -# if defined(_IBMR2) -# define SELECT_MASK void -# else -# define SELECT_MASK int -# endif -#endif - -/* - * Define "NBBY" (number of bits per byte) if it's not already defined. - */ - -#ifndef NBBY -# define NBBY 8 -#endif - -/* - * The following macro defines the number of fd_masks in an fd_set: - */ - -#ifndef FD_SETSIZE -# ifdef OPEN_MAX -# define FD_SETSIZE OPEN_MAX -# else -# define FD_SETSIZE 256 -# endif -#endif -#if !defined(howmany) -# define howmany(x, y) (((x)+((y)-1))/(y)) -#endif -#ifndef NFDBITS -# define NFDBITS NBBY*sizeof(fd_mask) -#endif -#define MASK_SIZE howmany(FD_SETSIZE, NFDBITS) - -/* - * Not all systems declare the errno variable in errno.h. so this - * file does it explicitly. The list of system error messages also - * isn't generally declared in a header file anywhere. - */ - -extern int errno; - -/* - * Variables provided by the C library: - */ - -#if defined(_sgi) || defined(__sgi) || (defined(__APPLE__) && defined(__DYNAMIC__)) -# define environ _environ -#endif -extern char **environ; - -/* - * At present (12/91) not all stdlib.h implementations declare strtod. - * The declaration below is here to ensure that it's declared, so that - * the compiler won't take the default approach of assuming it returns - * an int. There's no ANSI prototype for it because there would end - * up being too many conflicts with slightly-different prototypes. - */ - -extern double strtod(); - -/* - *--------------------------------------------------------------------------- - * The following macros and declarations represent the interface between - * generic and unix-specific parts of Tcl. Some of the macros may override - * functions declared in tclInt.h. - *--------------------------------------------------------------------------- - */ - -/* - * The default platform eol translation on Unix is TCL_TRANSLATE_LF. - */ - -#define TCL_PLATFORM_TRANSLATION TCL_TRANSLATE_LF - -/* - * The following macros have trivial definitions, allowing generic code to - * address platform-specific issues. - */ - -#define TclpAsyncMark(async) -#define TclpGetPid(pid) ((unsigned long) (pid)) -#define TclpReleaseFile(file) /* Nothing. */ - -/* - * The following defines wrap the system memory allocation routines for - * use by tclAlloc.c. By default off unused on Unix. - */ - -#if USE_TCLALLOC -# define TclpSysAlloc(size, isBin) malloc((size_t)size) -# define TclpSysFree(ptr) free((char*)ptr) -# define TclpSysRealloc(ptr, size) realloc((char*)ptr, (size_t)size) -#endif - -/* - * The following macros and declaration wrap the C runtime library - * functions. - */ - -#define TclpExit exit - -#ifdef TclpStat -#undef TclpStat -#endif - -EXTERN int TclpLstat _ANSI_ARGS_((CONST char *path, - struct stat *buf)); -EXTERN int TclpStat _ANSI_ARGS_((CONST char *path, - struct stat *buf)); - -/* - * Platform specific mutex definition used by memory allocators. - * These mutexes are statically allocated and explicitly initialized. - * Most modules do not use this, but instead use Tcl_Mutex types and - * Tcl_MutexLock and Tcl_MutexUnlock that are self-initializing. - */ - -#ifdef TCL_THREADS -#include <pthread.h> -typedef pthread_mutex_t TclpMutex; -EXTERN void TclpMutexInit _ANSI_ARGS_((TclpMutex *mPtr)); -EXTERN void TclpMutexLock _ANSI_ARGS_((TclpMutex *mPtr)); -EXTERN void TclpMutexUnlock _ANSI_ARGS_((TclpMutex *mPtr)); -#else -typedef int TclpMutex; -#define TclpMutexInit(a) -#define TclpMutexLock(a) -#define TclpMutexUnlock(a) -#endif /* TCL_THREADS */ - -#include "tclPlatDecls.h" -#include "tclIntPlatDecls.h" - -#endif /* _TCLUNIXPORT */ diff --git a/unix/tclUnixSock.c b/unix/tclUnixSock.c deleted file mode 100644 index 37d430e..0000000 --- a/unix/tclUnixSock.c +++ /dev/null @@ -1,135 +0,0 @@ -/* - * tclUnixSock.c -- - * - * This file contains Unix-specific socket related code. - * - * Copyright (c) 1995 Sun Microsystems, Inc. - * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclUnixSock.c,v 1.4 1999/04/16 00:48:05 stanton Exp $ - */ - -#include "tcl.h" -#include "tclPort.h" - -/* - * There is no portable macro for the maximum length - * of host names returned by gethostbyname(). We should only - * trust SYS_NMLN if it is at least 255 + 1 bytes to comply with DNS - * host name limits. - * - * Note: SYS_NMLN is a restriction on "uname" not on gethostbyname! - * - * For example HP-UX 10.20 has SYS_NMLN == 9, while gethostbyname() - * can return a fully qualified name from DNS of up to 255 bytes. - * - * Fix suggested by Viktor Dukhovni (viktor@esm.com) - */ - -#if defined(SYS_NMLN) && SYS_NMLEN >= 256 -#define TCL_HOSTNAME_LEN SYS_NMLEN -#else -#define TCL_HOSTNAME_LEN 256 -#endif - - -/* - * The following variable holds the network name of this host. - */ - -static char hostname[TCL_HOSTNAME_LEN + 1]; -static int hostnameInited = 0; -TCL_DECLARE_MUTEX(hostMutex) - - -/* - *---------------------------------------------------------------------- - * - * Tcl_GetHostName -- - * - * Returns the name of the local host. - * - * Results: - * A string containing the network name for this machine, or - * an empty string if we can't figure out the name. The caller - * must not modify or free this string. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -char * -Tcl_GetHostName() -{ -#ifndef NO_UNAME - struct utsname u; - struct hostent *hp; -#else - char buffer[sizeof(hostname)]; -#endif - CONST char *native; - - Tcl_MutexLock(&hostMutex); - if (hostnameInited) { - Tcl_MutexUnlock(&hostMutex); - return hostname; - } - - native = NULL; -#ifndef NO_UNAME - (VOID *) memset((VOID *) &u, (int) 0, sizeof(struct utsname)); - if (uname(&u) > -1) { /* INTL: Native. */ - hp = gethostbyname(u.nodename); /* INTL: Native. */ - if (hp != NULL) { - native = hp->h_name; - } else { - native = u.nodename; - } - } -#else - /* - * Uname doesn't exist; try gethostname instead. - */ - - if (gethostname(buffer, sizeof(buffer)) > -1) { /* INTL: Native. */ - native = buffer; - } -#endif - - if (native == NULL) { - hostname[0] = 0; - } else { - Tcl_ExternalToUtf(NULL, NULL, native, -1, 0, NULL, hostname, - sizeof(hostname), NULL, NULL, NULL); - } - hostnameInited = 1; - Tcl_MutexUnlock(&hostMutex); - return hostname; -} - -/* - *---------------------------------------------------------------------- - * - * TclpHasSockets -- - * - * Detect if sockets are available on this platform. - * - * Results: - * Returns TCL_OK. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -TclpHasSockets(interp) - Tcl_Interp *interp; /* Not used. */ -{ - return TCL_OK; -} diff --git a/unix/tclUnixTest.c b/unix/tclUnixTest.c deleted file mode 100644 index d556a2b..0000000 --- a/unix/tclUnixTest.c +++ /dev/null @@ -1,708 +0,0 @@ -/* - * tclUnixTest.c -- - * - * Contains platform specific test commands for the Unix platform. - * - * Copyright (c) 1996-1997 Sun Microsystems, Inc. - * Copyright (c) 1998 by Scriptics Corporation. - * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclUnixTest.c,v 1.11 1999/10/13 00:32:50 hobbs Exp $ - */ - -#include "tclInt.h" -#include "tclPort.h" - -/* - * The headers are needed for the testalarm command that verifies the - * use of SA_RESTART in signal handlers. - */ - -#include <signal.h> -#include <sys/resource.h> - -/* - * The following macros convert between TclFile's and fd's. The conversion - * simple involves shifting fd's up by one to ensure that no valid fd is ever - * the same as NULL. Note that this code is duplicated from tclUnixPipe.c - */ - -#define MakeFile(fd) ((TclFile)((fd)+1)) -#define GetFd(file) (((int)file)-1) - -/* - * The stuff below is used to keep track of file handlers created and - * exercised by the "testfilehandler" command. - */ - -typedef struct Pipe { - TclFile readFile; /* File handle for reading from the - * pipe. NULL means pipe doesn't exist yet. */ - TclFile writeFile; /* File handle for writing from the - * pipe. */ - int readCount; /* Number of times the file handler for - * this file has triggered and the file - * was readable. */ - int writeCount; /* Number of times the file handler for - * this file has triggered and the file - * was writable. */ -} Pipe; - -#define MAX_PIPES 10 -static Pipe testPipes[MAX_PIPES]; - -/* - * The stuff below is used by the testalarm and testgotsig ommands. - */ - -static char *gotsig = "0"; - -/* - * Forward declarations of procedures defined later in this file: - */ - -static void TestFileHandlerProc _ANSI_ARGS_((ClientData clientData, - int mask)); -static int TestfilehandlerCmd _ANSI_ARGS_((ClientData dummy, - Tcl_Interp *interp, int argc, char **argv)); -static int TestfilewaitCmd _ANSI_ARGS_((ClientData dummy, - Tcl_Interp *interp, int argc, char **argv)); -static int TestfindexecutableCmd _ANSI_ARGS_((ClientData dummy, - Tcl_Interp *interp, int argc, char **argv)); -static int TestgetopenfileCmd _ANSI_ARGS_((ClientData dummy, - Tcl_Interp *interp, int argc, char **argv)); -static int TestgetdefencdirCmd _ANSI_ARGS_((ClientData dummy, - Tcl_Interp *interp, int argc, char **argv)); -static int TestsetdefencdirCmd _ANSI_ARGS_((ClientData dummy, - Tcl_Interp *interp, int argc, char **argv)); -int TclplatformtestInit _ANSI_ARGS_((Tcl_Interp *interp)); -static int TestalarmCmd _ANSI_ARGS_((ClientData dummy, - Tcl_Interp *interp, int argc, char **argv)); -static int TestgotsigCmd _ANSI_ARGS_((ClientData dummy, - Tcl_Interp *interp, int argc, char **argv)); -static void AlarmHandler _ANSI_ARGS_(()); - -/* - *---------------------------------------------------------------------- - * - * TclplatformtestInit -- - * - * Defines commands that test platform specific functionality for - * Unix platforms. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * Defines new commands. - * - *---------------------------------------------------------------------- - */ - -int -TclplatformtestInit(interp) - Tcl_Interp *interp; /* Interpreter to add commands to. */ -{ - Tcl_CreateCommand(interp, "testfilehandler", TestfilehandlerCmd, - (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); - Tcl_CreateCommand(interp, "testfilewait", TestfilewaitCmd, - (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); - Tcl_CreateCommand(interp, "testfindexecutable", TestfindexecutableCmd, - (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); - Tcl_CreateCommand(interp, "testgetopenfile", TestgetopenfileCmd, - (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); - Tcl_CreateCommand(interp, "testgetdefenc", TestgetdefencdirCmd, - (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); - Tcl_CreateCommand(interp, "testsetdefenc", TestsetdefencdirCmd, - (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); - Tcl_CreateCommand(interp, "testalarm", TestalarmCmd, - (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); - Tcl_CreateCommand(interp, "testgotsig", TestgotsigCmd, - (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TestfilehandlerCmd -- - * - * This procedure implements the "testfilehandler" command. It is - * used to test Tcl_CreateFileHandler, Tcl_DeleteFileHandler, and - * TclWaitForFile. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -TestfilehandlerCmd(clientData, interp, argc, argv) - ClientData clientData; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ -{ - Pipe *pipePtr; - int i, mask, timeout; - static int initialized = 0; - char buffer[4000]; - TclFile file; - - /* - * NOTE: When we make this code work on Windows also, the following - * variable needs to be made Unix-only. - */ - - if (!initialized) { - for (i = 0; i < MAX_PIPES; i++) { - testPipes[i].readFile = NULL; - } - initialized = 1; - } - - if (argc < 2) { - Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], - " option ... \"", (char *) NULL); - return TCL_ERROR; - } - pipePtr = NULL; - if (argc >= 3) { - if (Tcl_GetInt(interp, argv[2], &i) != TCL_OK) { - return TCL_ERROR; - } - if (i >= MAX_PIPES) { - Tcl_AppendResult(interp, "bad index ", argv[2], (char *) NULL); - return TCL_ERROR; - } - pipePtr = &testPipes[i]; - } - - if (strcmp(argv[1], "close") == 0) { - for (i = 0; i < MAX_PIPES; i++) { - if (testPipes[i].readFile != NULL) { - TclpCloseFile(testPipes[i].readFile); - testPipes[i].readFile = NULL; - TclpCloseFile(testPipes[i].writeFile); - testPipes[i].writeFile = NULL; - } - } - } else if (strcmp(argv[1], "clear") == 0) { - if (argc != 3) { - Tcl_AppendResult(interp, "wrong # arguments: should be \"", - argv[0], " clear index\"", (char *) NULL); - return TCL_ERROR; - } - pipePtr->readCount = pipePtr->writeCount = 0; - } else if (strcmp(argv[1], "counts") == 0) { - char buf[TCL_INTEGER_SPACE * 2]; - - if (argc != 3) { - Tcl_AppendResult(interp, "wrong # arguments: should be \"", - argv[0], " counts index\"", (char *) NULL); - return TCL_ERROR; - } - sprintf(buf, "%d %d", pipePtr->readCount, pipePtr->writeCount); - Tcl_SetResult(interp, buf, TCL_VOLATILE); - } else if (strcmp(argv[1], "create") == 0) { - if (argc != 5) { - Tcl_AppendResult(interp, "wrong # arguments: should be \"", - argv[0], " create index readMode writeMode\"", - (char *) NULL); - return TCL_ERROR; - } - if (pipePtr->readFile == NULL) { - if (!TclpCreatePipe(&pipePtr->readFile, &pipePtr->writeFile)) { - Tcl_AppendResult(interp, "couldn't open pipe: ", - Tcl_PosixError(interp), (char *) NULL); - return TCL_ERROR; - } -#ifdef O_NONBLOCK - fcntl(GetFd(pipePtr->readFile), F_SETFL, O_NONBLOCK); - fcntl(GetFd(pipePtr->writeFile), F_SETFL, O_NONBLOCK); -#else - Tcl_SetResult(interp, "can't make pipes non-blocking", - TCL_STATIC); - return TCL_ERROR; -#endif - } - pipePtr->readCount = 0; - pipePtr->writeCount = 0; - - if (strcmp(argv[3], "readable") == 0) { - Tcl_CreateFileHandler(GetFd(pipePtr->readFile), TCL_READABLE, - TestFileHandlerProc, (ClientData) pipePtr); - } else if (strcmp(argv[3], "off") == 0) { - Tcl_DeleteFileHandler(GetFd(pipePtr->readFile)); - } else if (strcmp(argv[3], "disabled") == 0) { - Tcl_CreateFileHandler(GetFd(pipePtr->readFile), 0, - TestFileHandlerProc, (ClientData) pipePtr); - } else { - Tcl_AppendResult(interp, "bad read mode \"", argv[3], "\"", - (char *) NULL); - return TCL_ERROR; - } - if (strcmp(argv[4], "writable") == 0) { - Tcl_CreateFileHandler(GetFd(pipePtr->writeFile), TCL_WRITABLE, - TestFileHandlerProc, (ClientData) pipePtr); - } else if (strcmp(argv[4], "off") == 0) { - Tcl_DeleteFileHandler(GetFd(pipePtr->writeFile)); - } else if (strcmp(argv[4], "disabled") == 0) { - Tcl_CreateFileHandler(GetFd(pipePtr->writeFile), 0, - TestFileHandlerProc, (ClientData) pipePtr); - } else { - Tcl_AppendResult(interp, "bad read mode \"", argv[4], "\"", - (char *) NULL); - return TCL_ERROR; - } - } else if (strcmp(argv[1], "empty") == 0) { - if (argc != 3) { - Tcl_AppendResult(interp, "wrong # arguments: should be \"", - argv[0], " empty index\"", (char *) NULL); - return TCL_ERROR; - } - - while (read(GetFd(pipePtr->readFile), buffer, 4000) > 0) { - /* Empty loop body. */ - } - } else if (strcmp(argv[1], "fill") == 0) { - if (argc != 3) { - Tcl_AppendResult(interp, "wrong # arguments: should be \"", - argv[0], " empty index\"", (char *) NULL); - return TCL_ERROR; - } - - memset((VOID *) buffer, 'a', 4000); - while (write(GetFd(pipePtr->writeFile), buffer, 4000) > 0) { - /* Empty loop body. */ - } - } else if (strcmp(argv[1], "fillpartial") == 0) { - char buf[TCL_INTEGER_SPACE]; - - if (argc != 3) { - Tcl_AppendResult(interp, "wrong # arguments: should be \"", - argv[0], " empty index\"", (char *) NULL); - return TCL_ERROR; - } - - memset((VOID *) buffer, 'b', 10); - TclFormatInt(buf, write(GetFd(pipePtr->writeFile), buffer, 10)); - Tcl_SetResult(interp, buf, TCL_VOLATILE); - } else if (strcmp(argv[1], "oneevent") == 0) { - Tcl_DoOneEvent(TCL_FILE_EVENTS|TCL_DONT_WAIT); - } else if (strcmp(argv[1], "wait") == 0) { - if (argc != 5) { - Tcl_AppendResult(interp, "wrong # arguments: should be \"", - argv[0], " wait index readable/writable timeout\"", - (char *) NULL); - return TCL_ERROR; - } - if (pipePtr->readFile == NULL) { - Tcl_AppendResult(interp, "pipe ", argv[2], " doesn't exist", - (char *) NULL); - return TCL_ERROR; - } - if (strcmp(argv[3], "readable") == 0) { - mask = TCL_READABLE; - file = pipePtr->readFile; - } else { - mask = TCL_WRITABLE; - file = pipePtr->writeFile; - } - if (Tcl_GetInt(interp, argv[4], &timeout) != TCL_OK) { - return TCL_ERROR; - } - i = TclUnixWaitForFile(GetFd(file), mask, timeout); - if (i & TCL_READABLE) { - Tcl_AppendElement(interp, "readable"); - } - if (i & TCL_WRITABLE) { - Tcl_AppendElement(interp, "writable"); - } - } else if (strcmp(argv[1], "windowevent") == 0) { - Tcl_DoOneEvent(TCL_WINDOW_EVENTS|TCL_DONT_WAIT); - } else { - Tcl_AppendResult(interp, "bad option \"", argv[1], - "\": must be close, clear, counts, create, empty, fill, ", - "fillpartial, oneevent, wait, or windowevent", - (char *) NULL); - return TCL_ERROR; - } - return TCL_OK; -} - -static void TestFileHandlerProc(clientData, mask) - ClientData clientData; /* Points to a Pipe structure. */ - int mask; /* Indicates which events happened: - * TCL_READABLE or TCL_WRITABLE. */ -{ - Pipe *pipePtr = (Pipe *) clientData; - - if (mask & TCL_READABLE) { - pipePtr->readCount++; - } - if (mask & TCL_WRITABLE) { - pipePtr->writeCount++; - } -} - -/* - *---------------------------------------------------------------------- - * - * TestfilewaitCmd -- - * - * This procedure implements the "testfilewait" command. It is - * used to test TclUnixWaitForFile. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -TestfilewaitCmd(clientData, interp, argc, argv) - ClientData clientData; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ -{ - int mask, result, timeout; - Tcl_Channel channel; - int fd; - ClientData data; - - if (argc != 4) { - Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], - " file readable|writable|both timeout\"", (char *) NULL); - return TCL_ERROR; - } - channel = Tcl_GetChannel(interp, argv[1], NULL); - if (channel == NULL) { - return TCL_ERROR; - } - if (strcmp(argv[2], "readable") == 0) { - mask = TCL_READABLE; - } else if (strcmp(argv[2], "writable") == 0){ - mask = TCL_WRITABLE; - } else if (strcmp(argv[2], "both") == 0){ - mask = TCL_WRITABLE|TCL_READABLE; - } else { - Tcl_AppendResult(interp, "bad argument \"", argv[2], - "\": must be readable, writable, or both", (char *) NULL); - return TCL_ERROR; - } - if (Tcl_GetChannelHandle(channel, - (mask & TCL_READABLE) ? TCL_READABLE : TCL_WRITABLE, - (ClientData*) &data) != TCL_OK) { - Tcl_SetResult(interp, "couldn't get channel file", TCL_STATIC); - return TCL_ERROR; - } - fd = (int) data; - if (Tcl_GetInt(interp, argv[3], &timeout) != TCL_OK) { - return TCL_ERROR; - } - result = TclUnixWaitForFile(fd, mask, timeout); - if (result & TCL_READABLE) { - Tcl_AppendElement(interp, "readable"); - } - if (result & TCL_WRITABLE) { - Tcl_AppendElement(interp, "writable"); - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TestfindexecutableCmd -- - * - * This procedure implements the "testfindexecutable" command. It is - * used to test Tcl_FindExecutable. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -TestfindexecutableCmd(clientData, interp, argc, argv) - ClientData clientData; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ -{ - char *oldName; - char *oldNativeName; - - if (argc != 2) { - Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], - " argv0\"", (char *) NULL); - return TCL_ERROR; - } - - oldName = tclExecutableName; - oldNativeName = tclNativeExecutableName; - - tclExecutableName = NULL; - tclNativeExecutableName = NULL; - - Tcl_FindExecutable(argv[1]); - if (tclExecutableName != NULL) { - Tcl_SetResult(interp, tclExecutableName, TCL_VOLATILE); - ckfree(tclExecutableName); - } - if (tclNativeExecutableName != NULL) { - ckfree(tclNativeExecutableName); - } - - tclExecutableName = oldName; - tclNativeExecutableName = oldNativeName; - - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TestgetopenfileCmd -- - * - * This procedure implements the "testgetopenfile" command. It is - * used to get a FILE * value from a registered channel. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -TestgetopenfileCmd(clientData, interp, argc, argv) - ClientData clientData; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ -{ - ClientData filePtr; - - if (argc != 3) { - Tcl_AppendResult(interp, - "wrong # args: should be \"", argv[0], - " channelName forWriting\"", - (char *) NULL); - return TCL_ERROR; - } - if (Tcl_GetOpenFile(interp, argv[1], atoi(argv[2]), 1, &filePtr) - == TCL_ERROR) { - return TCL_ERROR; - } - if (filePtr == (ClientData) NULL) { - Tcl_AppendResult(interp, - "Tcl_GetOpenFile succeeded but FILE * NULL!", (char *) NULL); - return TCL_ERROR; - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TestsetdefencdirCmd -- - * - * This procedure implements the "testsetdefenc" command. It is - * used to set the value of tclDefaultEncodingDir. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -TestsetdefencdirCmd(clientData, interp, argc, argv) - ClientData clientData; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ -{ - if (argc != 2) { - Tcl_AppendResult(interp, - "wrong # args: should be \"", argv[0], - " defaultDir\"", - (char *) NULL); - return TCL_ERROR; - } - - if (tclDefaultEncodingDir != NULL) { - ckfree(tclDefaultEncodingDir); - tclDefaultEncodingDir = NULL; - } - if (*argv[1] != '\0') { - tclDefaultEncodingDir = (char *) - ckalloc((unsigned) strlen(argv[1]) + 1); - strcpy(tclDefaultEncodingDir, argv[1]); - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TestgetdefencdirCmd -- - * - * This procedure implements the "testgetdefenc" command. It is - * used to get the value of tclDefaultEncodingDir. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -TestgetdefencdirCmd(clientData, interp, argc, argv) - ClientData clientData; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ -{ - if (argc != 1) { - Tcl_AppendResult(interp, - "wrong # args: should be \"", argv[0], - (char *) NULL); - return TCL_ERROR; - } - - if (tclDefaultEncodingDir != NULL) { - Tcl_AppendResult(interp, tclDefaultEncodingDir, (char *) NULL); - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * TestalarmCmd -- - * - * Test that EINTR is handled correctly by generating and - * handling a signal. This requires using the SA_RESTART - * flag when registering the signal handler. - * - * Results: - * None. - * - * Side Effects: - * Sets up an signal and async handlers. - * - *---------------------------------------------------------------------- - */ - -static int -TestalarmCmd(clientData, interp, argc, argv) - ClientData clientData; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ -{ -#ifdef SA_RESTART - unsigned int sec; - struct sigaction action; - - if (argc > 1) { - Tcl_GetInt(interp, argv[1], (int *)&sec); - } else { - sec = 1; - } - - /* - * Setup the signal handling that automatically retries - * any interupted I/O system calls. - */ - action.sa_handler = AlarmHandler; - memset((void *)&action.sa_mask, 0, sizeof(sigset_t)); - action.sa_flags = SA_RESTART; - - if (sigaction(SIGALRM, &action, NULL) < 0) { - Tcl_AppendResult(interp, "sigaction: ", Tcl_PosixError(interp), NULL); - return TCL_ERROR; - } - if (alarm(sec) < 0) { - Tcl_AppendResult(interp, "alarm: ", Tcl_PosixError(interp), NULL); - return TCL_ERROR; - } - return TCL_OK; -#else - Tcl_AppendResult(interp, "warning: sigaction SA_RESTART not support on this platform", NULL); - return TCL_ERROR; -#endif -} - -/* - *---------------------------------------------------------------------- - * - * AlarmHandler -- - * - * Signal handler for the alarm command. - * - * Results: - * None. - * - * Side effects: - * Calls the Tcl Async handler. - * - *---------------------------------------------------------------------- - */ - -static void -AlarmHandler() -{ - gotsig = "1"; -} - -/* - *---------------------------------------------------------------------- - * TestgotsigCmd -- - * - * Verify the signal was handled after the testalarm command. - * - * Results: - * None. - * - * Side Effects: - * Resets the value of gotsig back to '0'. - * - *---------------------------------------------------------------------- - */ - -static int -TestgotsigCmd(clientData, interp, argc, argv) - ClientData clientData; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ -{ - Tcl_AppendResult(interp, gotsig, (char *) NULL); - gotsig = "0"; - return TCL_OK; -} diff --git a/unix/tclUnixThrd.c b/unix/tclUnixThrd.c deleted file mode 100644 index 2e8e8a4..0000000 --- a/unix/tclUnixThrd.c +++ /dev/null @@ -1,726 +0,0 @@ -/* - * tclUnixThrd.c -- - * - * This file implements the UNIX-specific thread support. - * - * Copyright (c) 1991-1994 The Regents of the University of California. - * Copyright (c) 1994-1997 Sun Microsystems, Inc. - * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * SCCS: @(#) tclUnixThrd.c 1.18 98/02/19 14:24:12 - */ - -#include "tclInt.h" - -#ifdef TCL_THREADS - -#include "tclPort.h" -#include "pthread.h" - -/* - * masterLock is used to serialize creation of mutexes, condition - * variables, and thread local storage. - * This is the only place that can count on the ability to statically - * initialize the mutex. - */ - -static pthread_mutex_t masterLock = PTHREAD_MUTEX_INITIALIZER; - -/* - * initLock is used to serialize initialization and finalization - * of Tcl. It cannot use any dyamically allocated storage. - */ - -static pthread_mutex_t initLock = PTHREAD_MUTEX_INITIALIZER; - -/* - * allocLock is used by Tcl's version of malloc for synchronization. - * For obvious reasons, cannot use any dyamically allocated storage. - */ - -static pthread_mutex_t allocLock = PTHREAD_MUTEX_INITIALIZER; -static pthread_mutex_t *allocLockPtr = &allocLock; - -/* - * These are for the critical sections inside this file. - */ - -#define MASTER_LOCK pthread_mutex_lock(&masterLock) -#define MASTER_UNLOCK pthread_mutex_unlock(&masterLock) - -#endif /* TCL_THREADS */ - - - - -/* - *---------------------------------------------------------------------- - * - * Tcl_CreateThread -- - * - * This procedure creates a new thread. - * - * Results: - * TCL_OK if the thread could be created. The thread ID is - * returned in a parameter. - * - * Side effects: - * A new thread is created. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_CreateThread(idPtr, proc, clientData, stackSize, flags) - Tcl_ThreadId *idPtr; /* Return, the ID of the thread */ - Tcl_ThreadCreateProc proc; /* Main() function of the thread */ - ClientData clientData; /* The one argument to Main() */ - int stackSize; /* Size of stack for the new thread */ - int flags; /* Flags controlling behaviour of - * the new thread */ -{ -#ifdef TCL_THREADS - pthread_attr_t attr; - int result; - - pthread_attr_init(&attr); - pthread_attr_setscope(&attr, PTHREAD_SCOPE_SYSTEM); - -#ifdef HAVE_PTHREAD_ATTR_SETSTACKSIZE - if (stackSize != TCL_THREAD_STACK_DEFAULT) { - pthread_attr_setstacksize(&attr, (size_t) stackSize); -#ifdef TCL_THREAD_STACK_MIN - } else { - /* - * Certain systems define a thread stack size that by default is - * too small for many operations. The user has the option of - * defining TCL_THREAD_STACK_MIN to a value large enough to work - * for their needs. This would look like (for 128K min stack): - * make MEM_DEBUG_FLAGS=-DTCL_THREAD_STACK_MIN=131072L - * - * This solution is not optimal, as we should allow the user to - * specify a size at runtime, but we don't want to slow this function - * down, and that would still leave the main thread at the default. - */ - - size_t size; - result = pthread_attr_getstacksize(&attr, &size); - if (!result && (size < TCL_THREAD_STACK_MIN)) { - pthread_attr_setstacksize(&attr, (size_t) TCL_THREAD_STACK_MIN); - } -#endif - } -#endif - if (! (flags & TCL_THREAD_JOINABLE)) { - pthread_attr_setdetachstate (&attr, PTHREAD_CREATE_DETACHED); - } - - - if (pthread_create((pthread_t *)idPtr, &attr, - (void * (*)())proc, (void *)clientData) && - pthread_create((pthread_t *)idPtr, NULL, - (void * (*)())proc, (void *)clientData)) { - result = TCL_ERROR; - } else { - result = TCL_OK; - } - pthread_attr_destroy(&attr); - return result; -#else - return TCL_ERROR; -#endif /* TCL_THREADS */ -} - -#ifdef TCL_THREADS -/* - *---------------------------------------------------------------------- - * - * TclpThreadExit -- - * - * This procedure terminates the current thread. - * - * Results: - * None. - * - * Side effects: - * This procedure terminates the current thread. - * - *---------------------------------------------------------------------- - */ - -void -TclpThreadExit(status) - int status; -{ - pthread_exit((VOID *)status); -} -#endif /* TCL_THREADS */ - -/* - *---------------------------------------------------------------------- - * - * Tcl_GetCurrentThread -- - * - * This procedure returns the ID of the currently running thread. - * - * Results: - * A thread ID. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -Tcl_ThreadId -Tcl_GetCurrentThread() -{ -#ifdef TCL_THREADS - return (Tcl_ThreadId) pthread_self(); -#else - return (Tcl_ThreadId) 0; -#endif -} - - -/* - *---------------------------------------------------------------------- - * - * TclpInitLock - * - * This procedure is used to grab a lock that serializes initialization - * and finalization of Tcl. On some platforms this may also initialize - * the mutex used to serialize creation of more mutexes and thread - * local storage keys. - * - * Results: - * None. - * - * Side effects: - * Acquire the initialization mutex. - * - *---------------------------------------------------------------------- - */ - -void -TclpInitLock() -{ -#ifdef TCL_THREADS - pthread_mutex_lock(&initLock); -#endif -} - - -/* - *---------------------------------------------------------------------- - * - * TclpInitUnlock - * - * This procedure is used to release a lock that serializes initialization - * and finalization of Tcl. - * - * Results: - * None. - * - * Side effects: - * Release the initialization mutex. - * - *---------------------------------------------------------------------- - */ - -void -TclpInitUnlock() -{ -#ifdef TCL_THREADS - pthread_mutex_unlock(&initLock); -#endif -} - -/* - *---------------------------------------------------------------------- - * - * TclpMasterLock - * - * This procedure is used to grab a lock that serializes creation - * and finalization of serialization objects. This interface is - * only needed in finalization; it is hidden during - * creation of the objects. - * - * This lock must be different than the initLock because the - * initLock is held during creation of syncronization objects. - * - * Results: - * None. - * - * Side effects: - * Acquire the master mutex. - * - *---------------------------------------------------------------------- - */ - -void -TclpMasterLock() -{ -#ifdef TCL_THREADS - pthread_mutex_lock(&masterLock); -#endif -} - - -/* - *---------------------------------------------------------------------- - * - * TclpMasterUnlock - * - * This procedure is used to release a lock that serializes creation - * and finalization of synchronization objects. - * - * Results: - * None. - * - * Side effects: - * Release the master mutex. - * - *---------------------------------------------------------------------- - */ - -void -TclpMasterUnlock() -{ -#ifdef TCL_THREADS - pthread_mutex_unlock(&masterLock); -#endif -} - - -/* - *---------------------------------------------------------------------- - * - * Tcl_GetAllocMutex - * - * This procedure returns a pointer to a statically initialized - * mutex for use by the memory allocator. The alloctor must - * use this lock, because all other locks are allocated... - * - * Results: - * A pointer to a mutex that is suitable for passing to - * Tcl_MutexLock and Tcl_MutexUnlock. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -Tcl_Mutex * -Tcl_GetAllocMutex() -{ -#ifdef TCL_THREADS - return (Tcl_Mutex *)&allocLockPtr; -#else - return NULL; -#endif -} - -#ifdef TCL_THREADS - -/* - *---------------------------------------------------------------------- - * - * Tcl_MutexLock -- - * - * This procedure is invoked to lock a mutex. This procedure - * handles initializing the mutex, if necessary. The caller - * can rely on the fact that Tcl_Mutex is an opaque pointer. - * This routine will change that pointer from NULL after first use. - * - * Results: - * None. - * - * Side effects: - * May block the current thread. The mutex is aquired when - * this returns. Will allocate memory for a pthread_mutex_t - * and initialize this the first time this Tcl_Mutex is used. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_MutexLock(mutexPtr) - Tcl_Mutex *mutexPtr; /* Really (pthread_mutex_t **) */ -{ - pthread_mutex_t *pmutexPtr; - if (*mutexPtr == NULL) { - MASTER_LOCK; - if (*mutexPtr == NULL) { - /* - * Double inside master lock check to avoid a race condition. - */ - - pmutexPtr = (pthread_mutex_t *)ckalloc(sizeof(pthread_mutex_t)); - pthread_mutex_init(pmutexPtr, NULL); - *mutexPtr = (Tcl_Mutex)pmutexPtr; - TclRememberMutex(mutexPtr); - } - MASTER_UNLOCK; - } - pmutexPtr = *((pthread_mutex_t **)mutexPtr); - pthread_mutex_lock(pmutexPtr); -} - - -/* - *---------------------------------------------------------------------- - * - * Tcl_MutexUnlock -- - * - * This procedure is invoked to unlock a mutex. The mutex must - * have been locked by Tcl_MutexLock. - * - * Results: - * None. - * - * Side effects: - * The mutex is released when this returns. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_MutexUnlock(mutexPtr) - Tcl_Mutex *mutexPtr; /* Really (pthread_mutex_t **) */ -{ - pthread_mutex_t *pmutexPtr = *(pthread_mutex_t **)mutexPtr; - pthread_mutex_unlock(pmutexPtr); -} - - -/* - *---------------------------------------------------------------------- - * - * TclpFinalizeMutex -- - * - * This procedure is invoked to clean up one mutex. This is only - * safe to call at the end of time. - * - * This assumes the Master Lock is held. - * - * Results: - * None. - * - * Side effects: - * The mutex list is deallocated. - * - *---------------------------------------------------------------------- - */ - -void -TclpFinalizeMutex(mutexPtr) - Tcl_Mutex *mutexPtr; -{ - pthread_mutex_t *pmutexPtr = *(pthread_mutex_t **)mutexPtr; - if (pmutexPtr != NULL) { - ckfree((char *)pmutexPtr); - *mutexPtr = NULL; - } -} - - -/* - *---------------------------------------------------------------------- - * - * TclpThreadDataKeyInit -- - * - * This procedure initializes a thread specific data block key. - * Each thread has table of pointers to thread specific data. - * all threads agree on which table entry is used by each module. - * this is remembered in a "data key", that is just an index into - * this table. To allow self initialization, the interface - * passes a pointer to this key and the first thread to use - * the key fills in the pointer to the key. The key should be - * a process-wide static. - * - * Results: - * None. - * - * Side effects: - * Will allocate memory the first time this process calls for - * this key. In this case it modifies its argument - * to hold the pointer to information about the key. - * - *---------------------------------------------------------------------- - */ - -void -TclpThreadDataKeyInit(keyPtr) - Tcl_ThreadDataKey *keyPtr; /* Identifier for the data chunk, - * really (pthread_key_t **) */ -{ - pthread_key_t *pkeyPtr; - - MASTER_LOCK; - if (*keyPtr == NULL) { - pkeyPtr = (pthread_key_t *)ckalloc(sizeof(pthread_key_t)); - pthread_key_create(pkeyPtr, NULL); - *keyPtr = (Tcl_ThreadDataKey)pkeyPtr; - TclRememberDataKey(keyPtr); - } - MASTER_UNLOCK; -} - -/* - *---------------------------------------------------------------------- - * - * TclpThreadDataKeyGet -- - * - * This procedure returns a pointer to a block of thread local storage. - * - * Results: - * A thread-specific pointer to the data structure, or NULL - * if the memory has not been assigned to this key for this thread. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -VOID * -TclpThreadDataKeyGet(keyPtr) - Tcl_ThreadDataKey *keyPtr; /* Identifier for the data chunk, - * really (pthread_key_t **) */ -{ - pthread_key_t *pkeyPtr = *(pthread_key_t **)keyPtr; - if (pkeyPtr == NULL) { - return NULL; - } else { - return (VOID *)pthread_getspecific(*pkeyPtr); - } -} - - -/* - *---------------------------------------------------------------------- - * - * TclpThreadDataKeySet -- - * - * This procedure sets the pointer to a block of thread local storage. - * - * Results: - * None. - * - * Side effects: - * Sets up the thread so future calls to TclpThreadDataKeyGet with - * this key will return the data pointer. - * - *---------------------------------------------------------------------- - */ - -void -TclpThreadDataKeySet(keyPtr, data) - Tcl_ThreadDataKey *keyPtr; /* Identifier for the data chunk, - * really (pthread_key_t **) */ - VOID *data; /* Thread local storage */ -{ - pthread_key_t *pkeyPtr = *(pthread_key_t **)keyPtr; - pthread_setspecific(*pkeyPtr, data); -} - -/* - *---------------------------------------------------------------------- - * - * TclpFinalizeThreadData -- - * - * This procedure cleans up the thread-local storage. This is - * called once for each thread. - * - * Results: - * None. - * - * Side effects: - * Frees up all thread local storage. - * - *---------------------------------------------------------------------- - */ - -void -TclpFinalizeThreadData(keyPtr) - Tcl_ThreadDataKey *keyPtr; -{ - VOID *result; - pthread_key_t *pkeyPtr; - - if (*keyPtr != NULL) { - pkeyPtr = *(pthread_key_t **)keyPtr; - result = (VOID *)pthread_getspecific(*pkeyPtr); - if (result != NULL) { - ckfree((char *)result); - pthread_setspecific(*pkeyPtr, (void *)NULL); - } - } -} - -/* - *---------------------------------------------------------------------- - * - * TclpFinalizeThreadDataKey -- - * - * This procedure is invoked to clean up one key. This is a - * process-wide storage identifier. The thread finalization code - * cleans up the thread local storage itself. - * - * This assumes the master lock is held. - * - * Results: - * None. - * - * Side effects: - * The key is deallocated. - * - *---------------------------------------------------------------------- - */ - -void -TclpFinalizeThreadDataKey(keyPtr) - Tcl_ThreadDataKey *keyPtr; -{ - pthread_key_t *pkeyPtr; - if (*keyPtr != NULL) { - pkeyPtr = *(pthread_key_t **)keyPtr; - pthread_key_delete(*pkeyPtr); - ckfree((char *)pkeyPtr); - *keyPtr = NULL; - } -} - - -/* - *---------------------------------------------------------------------- - * - * Tcl_ConditionWait -- - * - * This procedure is invoked to wait on a condition variable. - * The mutex is automically released as part of the wait, and - * automatically grabbed when the condition is signaled. - * - * The mutex must be held when this procedure is called. - * - * Results: - * None. - * - * Side effects: - * May block the current thread. The mutex is aquired when - * this returns. Will allocate memory for a pthread_mutex_t - * and initialize this the first time this Tcl_Mutex is used. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_ConditionWait(condPtr, mutexPtr, timePtr) - Tcl_Condition *condPtr; /* Really (pthread_cond_t **) */ - Tcl_Mutex *mutexPtr; /* Really (pthread_mutex_t **) */ - Tcl_Time *timePtr; /* Timeout on waiting period */ -{ - pthread_cond_t *pcondPtr; - pthread_mutex_t *pmutexPtr; - struct timespec ptime; - - if (*condPtr == NULL) { - MASTER_LOCK; - - /* - * Double check inside mutex to avoid race, - * then initialize condition variable if necessary. - */ - - if (*condPtr == NULL) { - pcondPtr = (pthread_cond_t *)ckalloc(sizeof(pthread_cond_t)); - pthread_cond_init(pcondPtr, NULL); - *condPtr = (Tcl_Condition)pcondPtr; - TclRememberCondition(condPtr); - } - MASTER_UNLOCK; - } - pmutexPtr = *((pthread_mutex_t **)mutexPtr); - pcondPtr = *((pthread_cond_t **)condPtr); - if (timePtr == NULL) { - pthread_cond_wait(pcondPtr, pmutexPtr); - } else { - ptime.tv_sec = timePtr->sec + TclpGetSeconds(); - ptime.tv_nsec = 1000 * timePtr->usec; - pthread_cond_timedwait(pcondPtr, pmutexPtr, &ptime); - } -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_ConditionNotify -- - * - * This procedure is invoked to signal a condition variable. - * - * The mutex must be held during this call to avoid races, - * but this interface does not enforce that. - * - * Results: - * None. - * - * Side effects: - * May unblock another thread. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_ConditionNotify(condPtr) - Tcl_Condition *condPtr; -{ - pthread_cond_t *pcondPtr = *((pthread_cond_t **)condPtr); - if (pcondPtr != NULL) { - pthread_cond_broadcast(pcondPtr); - } else { - /* - * Noone has used the condition variable, so there are no waiters. - */ - } -} - - -/* - *---------------------------------------------------------------------- - * - * TclpFinalizeCondition -- - * - * This procedure is invoked to clean up a condition variable. - * This is only safe to call at the end of time. - * - * This assumes the Master Lock is held. - * - * Results: - * None. - * - * Side effects: - * The condition variable is deallocated. - * - *---------------------------------------------------------------------- - */ - -void -TclpFinalizeCondition(condPtr) - Tcl_Condition *condPtr; -{ - pthread_cond_t *pcondPtr = *(pthread_cond_t **)condPtr; - if (pcondPtr != NULL) { - pthread_cond_destroy(pcondPtr); - ckfree((char *)pcondPtr); - *condPtr = NULL; - } -} - - - -#endif /* TCL_THREADS */ - diff --git a/unix/tclUnixThrd.h b/unix/tclUnixThrd.h deleted file mode 100644 index a4f6fc6..0000000 --- a/unix/tclUnixThrd.h +++ /dev/null @@ -1,21 +0,0 @@ -/* - * tclUnixThrd.h -- - * - * This header file defines things for thread support. - * - * Copyright (c) 1998 Sun Microsystems, Inc. - * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * SCCS: @(#) - */ - -#ifndef _TCLUNIXTHRD -#define _TCLUNIXTHRD - -#ifdef TCL_THREADS - - -#endif /* TCL_THREADS */ -#endif /* _TCLUNIXTHRD */ diff --git a/unix/tclUnixTime.c b/unix/tclUnixTime.c deleted file mode 100644 index 9990aad..0000000 --- a/unix/tclUnixTime.c +++ /dev/null @@ -1,310 +0,0 @@ -/* - * tclUnixTime.c -- - * - * Contains Unix specific versions of Tcl functions that - * obtain time values from the operating system. - * - * Copyright (c) 1995 Sun Microsystems, Inc. - * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclUnixTime.c,v 1.7 2000/01/14 22:15:52 ericm Exp $ - */ - -#include "tclInt.h" -#include "tclPort.h" -#define TM_YEAR_BASE 1900 -#define IsLeapYear(x) ((x % 4 == 0) && (x % 100 != 0 || x % 400 == 0)) - -/* - *----------------------------------------------------------------------------- - * - * TclpGetSeconds -- - * - * This procedure returns the number of seconds from the epoch. On - * most Unix systems the epoch is Midnight Jan 1, 1970 GMT. - * - * Results: - * Number of seconds from the epoch. - * - * Side effects: - * None. - * - *----------------------------------------------------------------------------- - */ - -unsigned long -TclpGetSeconds() -{ - return time((time_t *) NULL); -} - -/* - *----------------------------------------------------------------------------- - * - * TclpGetClicks -- - * - * This procedure returns a value that represents the highest resolution - * clock available on the system. There are no garantees on what the - * resolution will be. In Tcl we will call this value a "click". The - * start time is also system dependant. - * - * Results: - * Number of clicks from some start time. - * - * Side effects: - * None. - * - *----------------------------------------------------------------------------- - */ - -unsigned long -TclpGetClicks() -{ - unsigned long now; -#ifdef NO_GETTOD - struct tms dummy; -#else - struct timeval date; - struct timezone tz; -#endif - -#ifdef NO_GETTOD - now = (unsigned long) times(&dummy); -#else - gettimeofday(&date, &tz); - now = date.tv_sec*1000000 + date.tv_usec; -#endif - - return now; -} - -/* - *---------------------------------------------------------------------- - * - * TclpGetTimeZone -- - * - * Determines the current timezone. The method varies wildly - * between different platform implementations, so its hidden in - * this function. - * - * Results: - * The return value is the local time zone, measured in - * minutes away from GMT (-ve for east, +ve for west). - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -TclpGetTimeZone (currentTime) - unsigned long currentTime; -{ - /* - * Determine how a timezone is obtained from "struct tm". If there is no - * time zone in this struct (very lame) then use the timezone variable. - * This is done in a way to make the timezone variable the method of last - * resort, as some systems have it in addition to a field in "struct tm". - * The gettimeofday system call can also be used to determine the time - * zone. - */ - -#if defined(HAVE_TM_TZADJ) -# define TCL_GOT_TIMEZONE - time_t curTime = (time_t) currentTime; - struct tm *timeDataPtr = localtime(&curTime); - int timeZone; - - timeZone = timeDataPtr->tm_tzadj / 60; - if (timeDataPtr->tm_isdst) { - timeZone += 60; - } - - return timeZone; -#endif - -#if defined(HAVE_TM_GMTOFF) && !defined (TCL_GOT_TIMEZONE) -# define TCL_GOT_TIMEZONE - time_t curTime = (time_t) currentTime; - struct tm *timeDataPtr = localtime(&curTime); - int timeZone; - - timeZone = -(timeDataPtr->tm_gmtoff / 60); - if (timeDataPtr->tm_isdst) { - timeZone += 60; - } - - return timeZone; -#endif - -#if defined(USE_DELTA_FOR_TZ) -#define TCL_GOT_TIMEZONE 1 - /* - * This hack replaces using global var timezone or gettimeofday - * in situations where they are buggy such as on AIX when libbsd.a - * is linked in. - */ - - int timeZone; - time_t tt; - struct tm *stm; - tt = 849268800L; /* 1996-11-29 12:00:00 GMT */ - stm = localtime(&tt); /* eg 1996-11-29 6:00:00 CST6CDT */ - /* The calculation below assumes a max of +12 or -12 hours from GMT */ - timeZone = (12 - stm->tm_hour)*60 + (0 - stm->tm_min); - return timeZone; /* eg +360 for CST6CDT */ -#endif - - /* - * Must prefer timezone variable over gettimeofday, as gettimeofday does - * not return timezone information on many systems that have moved this - * information outside of the kernel. - */ - -#if defined(HAVE_TIMEZONE_VAR) && !defined (TCL_GOT_TIMEZONE) -# define TCL_GOT_TIMEZONE - static int setTZ = 0; -#ifdef TCL_THREADS - static Tcl_Mutex tzMutex; -#endif - int timeZone; - - Tcl_MutexLock(&tzMutex); - if (!setTZ) { - tzset(); - setTZ = 1; - } - Tcl_MutexUnlock(&tzMutex); - - /* - * Note: this is not a typo in "timezone" below! See tzset - * documentation for details. - */ - - timeZone = timezone / 60; - - return timeZone; -#endif - -#if !defined(NO_GETTOD) && !defined (TCL_GOT_TIMEZONE) -# define TCL_GOT_TIMEZONE - struct timeval tv; - struct timezone tz; - int timeZone; - - gettimeofday(&tv, &tz); - timeZone = tz.tz_minuteswest; - if (tz.tz_dsttime) { - timeZone += 60; - } - - return timeZone; -#endif - -#ifndef TCL_GOT_TIMEZONE - /* - * Cause compile error, we don't know how to get timezone. - */ - error: autoconf did not figure out how to determine the timezone. -#endif - -} - -/* - *---------------------------------------------------------------------- - * - * TclpGetTime -- - * - * Gets the current system time in seconds and microseconds - * since the beginning of the epoch: 00:00 UCT, January 1, 1970. - * - * Results: - * Returns the current time in timePtr. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -void -TclpGetTime(timePtr) - Tcl_Time *timePtr; /* Location to store time information. */ -{ - struct timeval tv; - struct timezone tz; - - (void) gettimeofday(&tv, &tz); - timePtr->sec = tv.tv_sec; - timePtr->usec = tv.tv_usec; -} - -/* - *---------------------------------------------------------------------- - * - * TclpGetDate -- - * - * This function converts between seconds and struct tm. If - * useGMT is true, then the returned date will be in Greenwich - * Mean Time (GMT). Otherwise, it will be in the local time zone. - * - * Results: - * Returns a static tm structure. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -struct tm * -TclpGetDate(time, useGMT) - TclpTime_t time; - int useGMT; -{ - CONST time_t *tp = (CONST time_t *)time; - - if (useGMT) { - return gmtime(tp); - } else { - return localtime(tp); - } -} - -/* - *---------------------------------------------------------------------- - * - * TclpStrftime -- - * - * On Unix, we can safely call the native strftime implementation. - * - * Results: - * The normal strftime result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -size_t -TclpStrftime(s, maxsize, format, t) - char *s; - size_t maxsize; - CONST char *format; - CONST struct tm *t; -{ - if (format[0] == '%' && format[1] == 'Q') { - /* Format as a stardate */ - sprintf(s, "Stardate %2d%03d.%01d", - (((t->tm_year + TM_YEAR_BASE) + 377) - 2323), - (((t->tm_yday + 1) * 1000) / - (365 + IsLeapYear((t->tm_year + TM_YEAR_BASE)))), - (((t->tm_hour * 60) + t->tm_min)/144)); - return(strlen(s)); - } - return strftime(s, maxsize, format, t); -} diff --git a/unix/tclXtNotify.c b/unix/tclXtNotify.c deleted file mode 100644 index 31157ff..0000000 --- a/unix/tclXtNotify.c +++ /dev/null @@ -1,668 +0,0 @@ -/* - * tclXtNotify.c -- - * - * This file contains the notifier driver implementation for the - * Xt intrinsics. - * - * Copyright (c) 1997 by Sun Microsystems, Inc. - * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclXtNotify.c,v 1.4 1999/07/02 06:05:34 welch Exp $ - */ - -#include <X11/Intrinsic.h> -#include <tclInt.h> - -/* - * This structure is used to keep track of the notifier info for a - * a registered file. - */ - -typedef struct FileHandler { - int fd; - int mask; /* Mask of desired events: TCL_READABLE, etc. */ - int readyMask; /* Events that have been seen since the - last time FileHandlerEventProc was called - for this file. */ - XtInputId read; /* Xt read callback handle. */ - XtInputId write; /* Xt write callback handle. */ - XtInputId except; /* Xt exception callback handle. */ - Tcl_FileProc *proc; /* Procedure to call, in the style of - * Tcl_CreateFileHandler. */ - ClientData clientData; /* Argument to pass to proc. */ - struct FileHandler *nextPtr;/* Next in list of all files we care about. */ -} FileHandler; - -/* - * The following structure is what is added to the Tcl event queue when - * file handlers are ready to fire. - */ - -typedef struct FileHandlerEvent { - Tcl_Event header; /* Information that is standard for - * all events. */ - int fd; /* File descriptor that is ready. Used - * to find the FileHandler structure for - * the file (can't point directly to the - * FileHandler structure because it could - * go away while the event is queued). */ -} FileHandlerEvent; - -/* - * The following static structure contains the state information for the - * Xt based implementation of the Tcl notifier. - */ - -static struct NotifierState { - XtAppContext appContext; /* The context used by the Xt - * notifier. Can be set with - * TclSetAppContext. */ - int appContextCreated; /* Was it created by us? */ - XtIntervalId currentTimeout; /* Handle of current timer. */ - FileHandler *firstFileHandlerPtr; /* Pointer to head of file handler - * list. */ -} notifier; - -/* - * The following static indicates whether this module has been initialized. - */ - -static int initialized = 0; - -/* - * Static routines defined in this file. - */ - -static int FileHandlerEventProc _ANSI_ARGS_((Tcl_Event *evPtr, - int flags)); -static void FileProc _ANSI_ARGS_((caddr_t clientData, - int *source, XtInputId *id)); -void InitNotifier _ANSI_ARGS_((void)); -static void NotifierExitHandler _ANSI_ARGS_(( - ClientData clientData)); -static void TimerProc _ANSI_ARGS_((caddr_t clientData, - XtIntervalId *id)); -static void CreateFileHandler _ANSI_ARGS_((int fd, int mask, - Tcl_FileProc * proc, ClientData clientData)); -static void DeleteFileHandler _ANSI_ARGS_((int fd)); -static void SetTimer _ANSI_ARGS_((Tcl_Time * timePtr)); -static int WaitForEvent _ANSI_ARGS_((Tcl_Time * timePtr)); - -/* - * Functions defined in this file for use by users of the Xt Notifier: - */ - -EXTERN XtAppContext TclSetAppContext _ANSI_ARGS_((XtAppContext ctx)); - -/* - *---------------------------------------------------------------------- - * - * TclSetAppContext -- - * - * Set the notifier application context. - * - * Results: - * None. - * - * Side effects: - * Sets the application context used by the notifier. Panics if - * the context is already set when called. - * - *---------------------------------------------------------------------- - */ - -XtAppContext -TclSetAppContext(appContext) - XtAppContext appContext; -{ - if (!initialized) { - InitNotifier(); - } - - /* - * If we already have a context we check whether we were asked to set a - * new context. If so, we panic because we try to prevent switching - * contexts by mistake. Otherwise, we return the one we have. - */ - - if (notifier.appContext != NULL) { - if (appContext != NULL) { - - /* - * We already have a context. We do not allow switching contexts - * after initialization, so we panic. - */ - - panic("TclSetAppContext: multiple application contexts"); - - } - } else { - - /* - * If we get here we have not yet gotten a context, so either create - * one or use the one supplied by our caller. - */ - - if (appContext == NULL) { - - /* - * We must create a new context and tell our caller what it is, so - * she can use it too. - */ - - notifier.appContext = XtCreateApplicationContext(); - notifier.appContextCreated = 1; - } else { - - /* - * Otherwise we remember the context that our caller gave us - * and use it. - */ - - notifier.appContextCreated = 0; - notifier.appContext = appContext; - } - } - - return notifier.appContext; -} - -/* - *---------------------------------------------------------------------- - * - * InitNotifier -- - * - * Initializes the notifier state. - * - * Results: - * None. - * - * Side effects: - * Creates a new exit handler. - * - *---------------------------------------------------------------------- - */ - -void -InitNotifier() -{ - Tcl_NotifierProcs notifier; - /* - * Only reinitialize if we are not in exit handling. The notifier - * can get reinitialized after its own exit handler has run, because - * of exit handlers for the I/O and timer sub-systems (order dependency). - */ - - if (TclInExit()) { - return; - } - - notifier.createFileHandlerProc = CreateFileHandler; - notifier.deleteFileHandlerProc = DeleteFileHandler; - notifier.setTimerProc = SetTimer; - notifier.waitForEventProc = WaitForEvent; - Tcl_SetNotifier(¬ifier); - - /* - * DO NOT create the application context yet; doing so would prevent - * external applications from setting it for us to their own ones. - */ - - initialized = 1; - memset(¬ifier, 0, sizeof(notifier)); - Tcl_CreateExitHandler(NotifierExitHandler, NULL); -} - -/* - *---------------------------------------------------------------------- - * - * NotifierExitHandler -- - * - * This function is called to cleanup the notifier state before - * Tcl is unloaded. - * - * Results: - * None. - * - * Side effects: - * Destroys the notifier window. - * - *---------------------------------------------------------------------- - */ - -static void -NotifierExitHandler( - ClientData clientData) /* Not used. */ -{ - if (notifier.currentTimeout != 0) { - XtRemoveTimeOut(notifier.currentTimeout); - } - for (; notifier.firstFileHandlerPtr != NULL; ) { - Tcl_DeleteFileHandler(notifier.firstFileHandlerPtr->fd); - } - if (notifier.appContextCreated) { - XtDestroyApplicationContext(notifier.appContext); - notifier.appContextCreated = 0; - notifier.appContext = NULL; - } - initialized = 0; -} - -/* - *---------------------------------------------------------------------- - * - * SetTimer -- - * - * This procedure sets the current notifier timeout value. - * - * Results: - * None. - * - * Side effects: - * Replaces any previous timer. - * - *---------------------------------------------------------------------- - */ - -static void -SetTimer(timePtr) - Tcl_Time *timePtr; /* Timeout value, may be NULL. */ -{ - long timeout; - - if (!initialized) { - InitNotifier(); - } - - TclSetAppContext(NULL); - if (notifier.currentTimeout != 0) { - XtRemoveTimeOut(notifier.currentTimeout); - } - if (timePtr) { - timeout = timePtr->sec * 1000 + timePtr->usec / 1000; - notifier.currentTimeout = - XtAppAddTimeOut(notifier.appContext, (unsigned long) timeout, - TimerProc, NULL); - } else { - notifier.currentTimeout = 0; - } -} - -/* - *---------------------------------------------------------------------- - * - * TimerProc -- - * - * This procedure is the XtTimerCallbackProc used to handle - * timeouts. - * - * Results: - * None. - * - * Side effects: - * Processes all queued events. - * - *---------------------------------------------------------------------- - */ - -static void -TimerProc(data, id) - caddr_t data; /* Not used. */ - XtIntervalId *id; -{ - if (*id != notifier.currentTimeout) { - return; - } - notifier.currentTimeout = 0; - - Tcl_ServiceAll(); -} - -/* - *---------------------------------------------------------------------- - * - * CreateFileHandler -- - * - * This procedure registers a file handler with the Xt notifier. - * - * Results: - * None. - * - * Side effects: - * Creates a new file handler structure and registers one or more - * input procedures with Xt. - * - *---------------------------------------------------------------------- - */ - -static void -CreateFileHandler(fd, mask, proc, clientData) - int fd; /* Handle of stream to watch. */ - int mask; /* OR'ed combination of TCL_READABLE, - * TCL_WRITABLE, and TCL_EXCEPTION: - * indicates conditions under which - * proc should be called. */ - Tcl_FileProc *proc; /* Procedure to call for each - * selected event. */ - ClientData clientData; /* Arbitrary data to pass to proc. */ -{ - FileHandler *filePtr; - - if (!initialized) { - InitNotifier(); - } - - TclSetAppContext(NULL); - - for (filePtr = notifier.firstFileHandlerPtr; filePtr != NULL; - filePtr = filePtr->nextPtr) { - if (filePtr->fd == fd) { - break; - } - } - if (filePtr == NULL) { - filePtr = (FileHandler*) ckalloc(sizeof(FileHandler)); - filePtr->fd = fd; - filePtr->read = 0; - filePtr->write = 0; - filePtr->except = 0; - filePtr->readyMask = 0; - filePtr->mask = 0; - filePtr->nextPtr = notifier.firstFileHandlerPtr; - notifier.firstFileHandlerPtr = filePtr; - } - filePtr->proc = proc; - filePtr->clientData = clientData; - - /* - * Register the file with the Xt notifier, if it hasn't been done yet. - */ - - if (mask & TCL_READABLE) { - if (!(filePtr->mask & TCL_READABLE)) { - filePtr->read = - XtAppAddInput(notifier.appContext, fd, XtInputReadMask, - FileProc, filePtr); - } - } else { - if (filePtr->mask & TCL_READABLE) { - XtRemoveInput(filePtr->read); - } - } - if (mask & TCL_WRITABLE) { - if (!(filePtr->mask & TCL_WRITABLE)) { - filePtr->write = - XtAppAddInput(notifier.appContext, fd, XtInputWriteMask, - FileProc, filePtr); - } - } else { - if (filePtr->mask & TCL_WRITABLE) { - XtRemoveInput(filePtr->write); - } - } - if (mask & TCL_EXCEPTION) { - if (!(filePtr->mask & TCL_EXCEPTION)) { - filePtr->except = - XtAppAddInput(notifier.appContext, fd, XtInputExceptMask, - FileProc, filePtr); - } - } else { - if (filePtr->mask & TCL_EXCEPTION) { - XtRemoveInput(filePtr->except); - } - } - filePtr->mask = mask; -} - -/* - *---------------------------------------------------------------------- - * - * DeleteFileHandler -- - * - * Cancel a previously-arranged callback arrangement for - * a file. - * - * Results: - * None. - * - * Side effects: - * If a callback was previously registered on file, remove it. - * - *---------------------------------------------------------------------- - */ - -static void -DeleteFileHandler(fd) - int fd; /* Stream id for which to remove - * callback procedure. */ -{ - FileHandler *filePtr, *prevPtr; - - if (!initialized) { - InitNotifier(); - } - - TclSetAppContext(NULL); - - /* - * Find the entry for the given file (and return if there - * isn't one). - */ - - for (prevPtr = NULL, filePtr = notifier.firstFileHandlerPtr; ; - prevPtr = filePtr, filePtr = filePtr->nextPtr) { - if (filePtr == NULL) { - return; - } - if (filePtr->fd == fd) { - break; - } - } - - /* - * Clean up information in the callback record. - */ - - if (prevPtr == NULL) { - notifier.firstFileHandlerPtr = filePtr->nextPtr; - } else { - prevPtr->nextPtr = filePtr->nextPtr; - } - if (filePtr->mask & TCL_READABLE) { - XtRemoveInput(filePtr->read); - } - if (filePtr->mask & TCL_WRITABLE) { - XtRemoveInput(filePtr->write); - } - if (filePtr->mask & TCL_EXCEPTION) { - XtRemoveInput(filePtr->except); - } - ckfree((char *) filePtr); -} - -/* - *---------------------------------------------------------------------- - * - * FileProc -- - * - * These procedures are called by Xt when a file becomes readable, - * writable, or has an exception. - * - * Results: - * None. - * - * Side effects: - * Makes an entry on the Tcl event queue if the event is - * interesting. - * - *---------------------------------------------------------------------- - */ - -static void -FileProc(clientData, fd, id) - caddr_t clientData; - int *fd; - XtInputId *id; -{ - FileHandler *filePtr = (FileHandler *)clientData; - FileHandlerEvent *fileEvPtr; - int mask = 0; - - /* - * Determine which event happened. - */ - - if (*id == filePtr->read) { - mask = TCL_READABLE; - } else if (*id == filePtr->write) { - mask = TCL_WRITABLE; - } else if (*id == filePtr->except) { - mask = TCL_EXCEPTION; - } - - /* - * Ignore unwanted or duplicate events. - */ - - if (!(filePtr->mask & mask) || (filePtr->readyMask & mask)) { - return; - } - - /* - * This is an interesting event, so put it onto the event queue. - */ - - filePtr->readyMask |= mask; - fileEvPtr = (FileHandlerEvent *) ckalloc(sizeof(FileHandlerEvent)); - fileEvPtr->header.proc = FileHandlerEventProc; - fileEvPtr->fd = filePtr->fd; - Tcl_QueueEvent((Tcl_Event *) fileEvPtr, TCL_QUEUE_TAIL); - - /* - * Process events on the Tcl event queue before returning to Xt. - */ - - Tcl_ServiceAll(); -} - -/* - *---------------------------------------------------------------------- - * - * FileHandlerEventProc -- - * - * This procedure is called by Tcl_ServiceEvent when a file event - * reaches the front of the event queue. This procedure is - * responsible for actually handling the event by invoking the - * callback for the file handler. - * - * Results: - * Returns 1 if the event was handled, meaning it should be removed - * from the queue. Returns 0 if the event was not handled, meaning - * it should stay on the queue. The only time the event isn't - * handled is if the TCL_FILE_EVENTS flag bit isn't set. - * - * Side effects: - * Whatever the file handler's callback procedure does. - * - *---------------------------------------------------------------------- - */ - -static int -FileHandlerEventProc(evPtr, flags) - Tcl_Event *evPtr; /* Event to service. */ - int flags; /* Flags that indicate what events to - * handle, such as TCL_FILE_EVENTS. */ -{ - FileHandler *filePtr; - FileHandlerEvent *fileEvPtr = (FileHandlerEvent *) evPtr; - int mask; - - if (!(flags & TCL_FILE_EVENTS)) { - return 0; - } - - /* - * Search through the file handlers to find the one whose handle matches - * the event. We do this rather than keeping a pointer to the file - * handler directly in the event, so that the handler can be deleted - * while the event is queued without leaving a dangling pointer. - */ - - for (filePtr = notifier.firstFileHandlerPtr; filePtr != NULL; - filePtr = filePtr->nextPtr) { - if (filePtr->fd != fileEvPtr->fd) { - continue; - } - - /* - * The code is tricky for two reasons: - * 1. The file handler's desired events could have changed - * since the time when the event was queued, so AND the - * ready mask with the desired mask. - * 2. The file could have been closed and re-opened since - * the time when the event was queued. This is why the - * ready mask is stored in the file handler rather than - * the queued event: it will be zeroed when a new - * file handler is created for the newly opened file. - */ - - mask = filePtr->readyMask & filePtr->mask; - filePtr->readyMask = 0; - if (mask != 0) { - (*filePtr->proc)(filePtr->clientData, mask); - } - break; - } - return 1; -} - -/* - *---------------------------------------------------------------------- - * - * WaitForEvent -- - * - * This function is called by Tcl_DoOneEvent to wait for new - * events on the message queue. If the block time is 0, then - * Tcl_WaitForEvent just polls without blocking. - * - * Results: - * Returns 1 if an event was found, else 0. This ensures that - * Tcl_DoOneEvent will return 1, even if the event is handled - * by non-Tcl code. - * - * Side effects: - * Queues file events that are detected by the select. - * - *---------------------------------------------------------------------- - */ - -static int -WaitForEvent( - Tcl_Time *timePtr) /* Maximum block time, or NULL. */ -{ - int timeout; - - if (!initialized) { - InitNotifier(); - } - - TclSetAppContext(NULL); - - if (timePtr) { - timeout = timePtr->sec * 1000 + timePtr->usec / 1000; - if (timeout == 0) { - if (XtAppPending(notifier.appContext)) { - goto process; - } else { - return 0; - } - } else { - Tcl_SetTimer(timePtr); - } - } -process: - XtAppProcessEvent(notifier.appContext, XtIMAll); - return 1; -} diff --git a/unix/tclXtTest.c b/unix/tclXtTest.c deleted file mode 100644 index abdcb8d..0000000 --- a/unix/tclXtTest.c +++ /dev/null @@ -1,120 +0,0 @@ -/* - * tclXtTest.c -- - * - * Contains commands for Xt notifier specific tests on Unix. - * - * Copyright (c) 1997 by Sun Microsystems, Inc. - * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclXtTest.c,v 1.4 1999/07/02 06:05:34 welch Exp $ - */ - -#include <X11/Intrinsic.h> -#include "tcl.h" - -static int TesteventloopCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -extern void InitNotifier _ANSI_ARGS_((void)); - - -/* - *---------------------------------------------------------------------- - * - * Tclxttest_Init -- - * - * This procedure performs application-specific initialization. - * Most applications, especially those that incorporate additional - * packages, will have their own version of this procedure. - * - * Results: - * Returns a standard Tcl completion code, and leaves an error - * message in the interp's result if an error occurs. - * - * Side effects: - * Depends on the startup script. - * - *---------------------------------------------------------------------- - */ - -int -Tclxttest_Init(interp) - Tcl_Interp *interp; /* Interpreter for application. */ -{ - if (Tcl_InitStubs(interp, TCL_VERSION, 0) == NULL) { - return TCL_ERROR; - } - XtToolkitInitialize(); - InitNotifier(); - Tcl_CreateCommand(interp, "testeventloop", TesteventloopCmd, - (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TesteventloopCmd -- - * - * This procedure implements the "testeventloop" command. It is - * used to test the Tcl notifier from an "external" event loop - * (i.e. not Tcl_DoOneEvent()). - * - * Results: - * A standard Tcl result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -TesteventloopCmd(clientData, interp, argc, argv) - ClientData clientData; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ -{ - static int *framePtr = NULL; /* Pointer to integer on stack frame of - * innermost invocation of the "wait" - * subcommand. */ - - if (argc < 2) { - Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], - " option ... \"", (char *) NULL); - return TCL_ERROR; - } - if (strcmp(argv[1], "done") == 0) { - *framePtr = 1; - } else if (strcmp(argv[1], "wait") == 0) { - int *oldFramePtr; - int done; - int oldMode = Tcl_SetServiceMode(TCL_SERVICE_ALL); - - /* - * Save the old stack frame pointer and set up the current frame. - */ - - oldFramePtr = framePtr; - framePtr = &done; - - /* - * Enter an Xt event loop until the flag changes. - * Note that we do not explicitly call Tcl_ServiceEvent(). - */ - - done = 0; - while (!done) { - XtAppProcessEvent(TclSetAppContext(NULL), XtIMAll); - } - (void) Tcl_SetServiceMode(oldMode); - framePtr = oldFramePtr; - } else { - Tcl_AppendResult(interp, "bad option \"", argv[1], - "\": must be done or wait", (char *) NULL); - return TCL_ERROR; - } - return TCL_OK; -} diff --git a/win/Makefile.in b/win/Makefile.in deleted file mode 100644 index c0cce6d..0000000 --- a/win/Makefile.in +++ /dev/null @@ -1,557 +0,0 @@ -# -# This file is a Makefile for Tcl. 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. -# -# RCS: @(#) $Id: Makefile.in,v 1.33.2.3 2000/07/28 07:58:28 mo Exp $ - -VERSION = @TCL_VERSION@ - -#---------------------------------------------------------------- -# Things you can change to personalize the Makefile for your own -# site (you can make these changes in either Makefile.in or -# Makefile, but changes to Makefile will get lost if you re-run -# the configuration script). -#---------------------------------------------------------------- - -# Default top-level directories in which to install architecture- -# specific files (exec_prefix) and machine-independent files such -# as scripts (prefix). The values specified here may be overridden -# at configure-time with the --exec-prefix and --prefix options -# to the "configure" script. - -prefix = @prefix@ -exec_prefix = @exec_prefix@ -bindir = @bindir@ -libdir = @libdir@ -includedir = @includedir@ -mandir = @mandir@ - -# The following definition can be set to non-null for special systems -# like AFS with replication. It allows the pathnames used for installation -# to be different than those used for actually reference files at -# run-time. INSTALL_ROOT is prepended to $prefix and $exec_prefix -# when installing files. -INSTALL_ROOT = - -# Directory from which applications will reference the library of Tcl -# scripts (note: you can set the TCL_LIBRARY environment variable at -# run-time to override this value): -TCL_LIBRARY = $(prefix)/lib/tcl$(VERSION) - -# Path to use at runtime to refer to LIB_INSTALL_DIR: -LIB_RUNTIME_DIR = $(libdir) - -# Directory in which to install the program tclsh: -BIN_INSTALL_DIR = $(INSTALL_ROOT)$(bindir) - -# Directory in which to install the .a or .so binary for the Tcl library: -LIB_INSTALL_DIR = $(INSTALL_ROOT)$(libdir) - -# Path name to use when installing library scripts. -SCRIPT_INSTALL_DIR = $(INSTALL_ROOT)$(TCL_LIBRARY) - -# Directory in which to install the include file tcl.h: -INCLUDE_INSTALL_DIR = $(INSTALL_ROOT)$(includedir) - -# Top-level directory in which to install manual entries: -MAN_INSTALL_DIR = $(INSTALL_ROOT)$(mandir) - -# Directory in which to install manual entry for tclsh: -MAN1_INSTALL_DIR = $(MAN_INSTALL_DIR)/man1 - -# Directory in which to install manual entries for Tcl's C library -# procedures: -MAN3_INSTALL_DIR = $(MAN_INSTALL_DIR)/man3 - -# Directory in which to install manual entries for the built-in -# Tcl commands: -MANN_INSTALL_DIR = $(MAN_INSTALL_DIR)/mann - -# Libraries built with optimization switches have this additional extension -TCL_DBGX = @TCL_DBGX@ - -# warning flags -CFLAGS_WARNING = @CFLAGS_WARNING@ - -# The default switches for optimization or debugging -CFLAGS_DEBUG = @CFLAGS_DEBUG@ -CFLAGS_OPTIMIZE = @CFLAGS_OPTIMIZE@ - -# To enable compilation debugging reverse the comment characters on -# one of the following lines. -COMPILE_DEBUG_FLAGS = -#COMPILE_DEBUG_FLAGS = -DTCL_COMPILE_DEBUG -#COMPILE_DEBUG_FLAGS = -DTCL_COMPILE_DEBUG -DTCL_COMPILE_STATS - -# The default switches for optimization or debugging -LDFLAGS_DEBUG = @LDFLAGS_DEBUG@ -LDFLAGS_OPTIMIZE = @LDFLAGS_OPTIMIZE@ - -# To change the compiler switches, for example to change from optimization to -# debugging symbols, change the following line: -#CFLAGS = $(CFLAGS_DEBUG) -#CFLAGS = $(CFLAGS_OPTIMIZE) -#CFLAGS = $(CFLAGS_DEBUG) $(CFLAGS_OPTIMIZE) -CFLAGS = @CFLAGS@ - -# Special compiler flags to use when building man2tcl on Windows. -MAN2TCLFLAGS = @MAN2TCLFLAGS@ - -SRC_DIR = @srcdir@ -ROOT_DIR = @srcdir@/.. -GENERIC_DIR = @srcdir@/../generic -WIN_DIR = @srcdir@ -COMPAT_DIR = @srcdir@/../compat - -# This is a switch passed to a Cygwin script that generates file -# names based on the platform. -PATHTYPE = @PATHTYPE@ - -# This program converts between Windows native and Cygwin POSIX pathnames. -CYGPATH = @CYGPATH@ - -GENERIC_DIR_NATIVE = $(shell $(CYGPATH) $(PATHTYPE) '$(GENERIC_DIR)') -WIN_DIR_NATIVE = $(shell $(CYGPATH) $(PATHTYPE) '$(WIN_DIR)') -ROOT_DIR_NATIVE = $(shell $(CYGPATH) $(PATHTYPE) '$(ROOT_DIR)') - -LIBRARY_DIR = $(shell echo '$(ROOT_DIR_NATIVE)/library' | sed 's/\\/\//g' ) - -DLLSUFFIX = @DLLSUFFIX@ -LIBSUFFIX = @LIBSUFFIX@ -EXESUFFIX = @EXESUFFIX@ - -TCL_STUB_LIB_FILE = @TCL_STUB_LIB_FILE@ -TCL_DLL_FILE = @TCL_DLL_FILE@ -TCL_LIB_FILE = @TCL_LIB_FILE@ -DDE_DLL_FILE = tcldde$(VER)${DLLSUFFIX} -DDE_LIB_FILE = tcldde$(VER)${LIBSUFFIX} -REG_DLL_FILE = tclreg$(VER)${DLLSUFFIX} -REG_LIB_FILE = tclreg$(VER)${LIBSUFFIX} -PIPE_DLL_FILE = tclpip$(VER)${DLLSUFFIX} - -SHARED_LIBRARIES = $(TCL_DLL_FILE) $(TCL_STUB_LIB_FILE) \ - $(DDE_DLL_FILE) $(REG_DLL_FILE) $(PIPE_DLL_FILE) -STATIC_LIBRARIES = $(TCL_LIB_FILE) $(REG_LIB_FILE) $(DDE_LIB_FILE) - -TCLSH = tclsh$(VER)${EXESUFFIX} -TCLTEST = tcltest${EXEEXT} -CAT32 = cat32$(EXEEXT) -MAN2TCL = man2tcl$(EXEEXT) - -@SET_MAKE@ - -# Macro that expands to the first dependency argument with the appropriate -# path type already resolved. - -DEPARG = "$(shell $(CYGPATH) $(PATHTYPE) $<)" - -# Setting the VPATH variable to a list of paths will cause the -# makefile to look into these paths when resolving .c to .obj -# dependencies. Note the ':' to avoid autoconf's habit of deleting -# all VPATH lines without an explicit ':' in it. - -VPATH = $(GENERIC_DIR)@VPSEP@$(WIN_DIR)@VPSEP@$(COMPAT_DIR) # : - -AR = @AR@ -RANLIB = @RANLIB@ -CC = @CC@ -RC = @RC@ -RES = @RES@ -AC_FLAGS = @EXTRA_CFLAGS@ @DEFS@ -CPPFLAGS = @CPPFLAGS@ -LDFLAGS = @LDFLAGS@ -LDFLAGS_CONSOLE = @LDFLAGS_CONSOLE@ -LDFLAGS_WINDOW = @LDFLAGS_WINDOW@ -EXEEXT = @EXEEXT@ -OBJEXT = @OBJEXT@ -STLIB_LD = @STLIB_LD@ -SHLIB_LD = @SHLIB_LD@ -SHLIB_LD_LIBS = @SHLIB_LD_LIBS@ $(LIBS) -SHLIB_CFLAGS = @SHLIB_CFLAGS@ -SHLIB_SUFFIX = @SHLIB_SUFFIX@ -VER = @TCL_MAJOR_VERSION@@TCL_MINOR_VERSION@ -DOTVER = @TCL_MAJOR_VERSION@.@TCL_MINOR_VERSION@ -LIBS = @LIBS@ - -RMDIR = rm -rf -MKDIR = mkdir -p -SHELL = @SHELL@ -RM = rm -f -COPY = cp - -CC_SWITCHES = ${CFLAGS} ${CFLAGS_WARNING} ${TCL_SHLIB_CFLAGS} \ --I"${GENERIC_DIR_NATIVE}" -I"${WIN_DIR_NATIVE}" ${AC_FLAGS} \ -${COMPILE_DEBUG_FLAGS} - -CC_OBJNAME = @CC_OBJNAME@ -CC_EXENAME = @CC_EXENAME@ - -STUB_CC_SWITCHES = ${CFLAGS} ${CFLAGS_WARNING} ${SHLIB_CFLAGS} \ --I"${GENERIC_DIR_NATIVE}" -I"${WIN_DIR_NATIVE}" ${AC_FLAGS} \ -${COMPILE_DEBUG_FLAGS} - -TCLTEST_OBJS = \ - tclTest.$(OBJEXT) \ - tclTestObj.$(OBJEXT) \ - tclTestProcBodyObj.$(OBJEXT) \ - tclThreadTest.$(OBJEXT) \ - tclWinTest.$(OBJEXT) \ - testMain.$(OBJEXT) - -GENERIC_OBJS = \ - regcomp.$(OBJEXT) \ - regexec.$(OBJEXT) \ - regfree.$(OBJEXT) \ - regerror.$(OBJEXT) \ - tclAlloc.$(OBJEXT) \ - tclAsync.$(OBJEXT) \ - tclBasic.$(OBJEXT) \ - tclBinary.$(OBJEXT) \ - tclCkalloc.$(OBJEXT) \ - tclClock.$(OBJEXT) \ - tclCmdAH.$(OBJEXT) \ - tclCmdIL.$(OBJEXT) \ - tclCmdMZ.$(OBJEXT) \ - tclCompCmds.$(OBJEXT) \ - tclCompExpr.$(OBJEXT) \ - tclCompile.$(OBJEXT) \ - tclDate.$(OBJEXT) \ - tclEncoding.$(OBJEXT) \ - tclEnv.$(OBJEXT) \ - tclEvent.$(OBJEXT) \ - tclExecute.$(OBJEXT) \ - tclFCmd.$(OBJEXT) \ - tclFileName.$(OBJEXT) \ - tclGet.$(OBJEXT) \ - tclHash.$(OBJEXT) \ - tclHistory.$(OBJEXT) \ - tclIndexObj.$(OBJEXT) \ - tclInterp.$(OBJEXT) \ - tclIO.$(OBJEXT) \ - tclIOCmd.$(OBJEXT) \ - tclIOGT.$(OBJEXT) \ - tclIOSock.$(OBJEXT) \ - tclIOUtil.$(OBJEXT) \ - tclLink.$(OBJEXT) \ - tclLiteral.$(OBJEXT) \ - tclListObj.$(OBJEXT) \ - tclLoad.$(OBJEXT) \ - tclMain.$(OBJEXT) \ - tclNamesp.$(OBJEXT) \ - tclNotify.$(OBJEXT) \ - tclObj.$(OBJEXT) \ - tclPanic.$(OBJEXT) \ - tclParse.$(OBJEXT) \ - tclParseExpr.$(OBJEXT) \ - tclPipe.$(OBJEXT) \ - tclPkg.$(OBJEXT) \ - tclPosixStr.$(OBJEXT) \ - tclPreserve.$(OBJEXT) \ - tclProc.$(OBJEXT) \ - tclRegexp.$(OBJEXT) \ - tclResolve.$(OBJEXT) \ - tclResult.$(OBJEXT) \ - tclScan.$(OBJEXT) \ - tclStringObj.$(OBJEXT) \ - tclStubInit.$(OBJEXT) \ - tclStubLib.$(OBJEXT) \ - tclThread.$(OBJEXT) \ - tclTimer.$(OBJEXT) \ - tclUtf.$(OBJEXT) \ - tclUtil.$(OBJEXT) \ - tclVar.$(OBJEXT) - -WIN_OBJS = \ - tclWin32Dll.$(OBJEXT) \ - tclWinChan.$(OBJEXT) \ - tclWinConsole.$(OBJEXT) \ - tclWinSerial.$(OBJEXT) \ - tclWinError.$(OBJEXT) \ - tclWinFCmd.$(OBJEXT) \ - tclWinFile.$(OBJEXT) \ - tclWinInit.$(OBJEXT) \ - tclWinLoad.$(OBJEXT) \ - tclWinMtherr.$(OBJEXT) \ - tclWinNotify.$(OBJEXT) \ - tclWinPipe.$(OBJEXT) \ - tclWinSock.$(OBJEXT) \ - tclWinThrd.$(OBJEXT) \ - tclWinTime.$(OBJEXT) - -COMPAT_OBJS = \ - strftime.$(OBJEXT) - -PIPE_OBJS = stub16.$(OBJEXT) - -DDE_OBJS = tclWinDde.$(OBJEXT) - -REG_OBJS = tclWinReg.$(OBJEXT) - -STUB_OBJS = tclStubLib.$(OBJEXT) - -TCLSH_OBJS = tclAppInit.$(OBJEXT) - -TCL_OBJS = ${GENERIC_OBJS} ${WIN_OBJS} ${COMPAT_OBJS} - -TCL_DOCS = "$(ROOT_DIR_NATIVE)"/doc/*.[13n] - -all: binaries libraries doc - -tcltest: $(TCLTEST) - -binaries: @LIBRARIES@ $(TCLSH) - -libraries: - -doc: - -winhelp: $(ROOT_DIR)/tools/man2help.tcl $(MAN2TCL) - TCL_LIBRARY="$(LIBRARY_DIR)"; export TCL_LIBRARY; \ - ./$(TCLSH) "$(ROOT_DIR_NATIVE)"/tools/man2help.tcl tcl "$(VER)" $(TCL_DOCS) - hcw /c /e tcl.hpj - -$(MAN2TCL): $(ROOT_DIR)/tools/man2tcl.c - $(CC) $(CFLAGS_OPTIMIZE) $(MAN2TCLFLAGS) -o $(MAN2TCL) "$(ROOT_DIR_NATIVE)"/tools/man2tcl.c - -$(TCLSH): $(TCL_LIB_FILE) $(TCLSH_OBJS) tclsh.$(RES) - $(CC) $(CFLAGS) $(TCLSH_OBJS) $(TCL_LIB_FILE) $(LIBS) \ - tclsh.$(RES) $(CC_EXENAME) - -$(TCLTEST): $(TCL_LIB_FILE) $(TCLTEST_OBJS) $(CAT32) tclsh.$(RES) - $(CC) $(CFLAGS) $(TCLTEST_OBJS) $(TCL_LIB_FILE) $(LIBS) \ - tclsh.$(RES) $(CC_EXENAME) - -cat32.$(OBJEXT): cat.c - $(CC) -c $(CC_SWITCHES) $(DEPARG) $(CC_OBJNAME) - -$(CAT32): cat32.$(OBJEXT) - $(CC) $(CFLAGS) cat32.$(OBJEXT) $(CC_EXENAME) $(LDFLAGS_CONSOLE) - -# The following targets are configured by autoconf to generate either -# a shared library or static library - -${TCL_STUB_LIB_FILE}: ${STUB_OBJS} - @$(RM) ${TCL_STUB_LIB_FILE} - @MAKE_LIB@ ${STUB_OBJS} - @POST_MAKE_LIB@ - -${TCL_DLL_FILE}: ${TCL_OBJS} tcl.$(RES) - @$(RM) ${TCL_DLL_FILE} - @MAKE_DLL@ ${TCL_OBJS} tcl.$(RES) $(SHLIB_LD_LIBS) - -${TCL_LIB_FILE}: ${TCL_OBJS} - @$(RM) ${TCL_LIB_FILE} - @MAKE_LIB@ ${TCL_OBJS} - @POST_MAKE_LIB@ - -${DDE_DLL_FILE}: ${DDE_OBJS} ${TCL_STUB_LIB_FILE} - @$(RM) ${DDE_DLL_FILE} - @MAKE_DLL@ ${DDE_OBJS} $(TCL_STUB_LIB_FILE) $(SHLIB_LD_LIBS) - -${DDE_LIB_FILE}: ${DDE_OBJS} ${TCL_LIB_FILE} - @$(RM) ${DDE_LIB_FILE} - @MAKE_LIB@ ${DDE_OBJS} ${TCL_LIB_FILE} - -${REG_DLL_FILE}: ${REG_OBJS} ${TCL_STUB_LIB_FILE} - @$(RM) ${REG_DLL_FILE} - @MAKE_DLL@ ${REG_OBJS} ${TCL_STUB_LIB_FILE} $(SHLIB_LD_LIBS) - -${REG_LIB_FILE}: ${REG_OBJS} ${TCL_LIB_FILE} - @$(RM) ${REG_LIB_FILE} - @MAKE_LIB@ ${REG_OBJS} ${TCL_LIB_FILE} - -# PIPE_DLL_FILE is actually an executable, don't build it -# like a DLL. - -${PIPE_DLL_FILE}: ${PIPE_OBJS} - @$(RM) ${PIPE_DLL_FILE} - @MAKE_EXE@ $(CFLAGS) ${PIPE_OBJS} $(LIBS) - -# Add the object extension to the implicit rules. By default .obj is not -# automatically added. - -.SUFFIXES: .${OBJEXT} -.SUFFIXES: .$(RES) -.SUFFIXES: .rc - -# Special case object targets - -tclWinInit.${OBJEXT}: tclWinInit.c - $(CC) -c $(CC_SWITCHES) -DBUILD_tcl $(EXTFLAGS) $(DEPARG) $(CC_OBJNAME) - -testMain.${OBJEXT}: tclAppInit.c - $(CC) -c $(CC_SWITCHES) -DTCL_TEST $(DEPARG) $(CC_OBJNAME) - -tclTest.${OBJEXT}: tclTest.c - $(CC) -c $(CC_SWITCHES) $(DEPARG) $(CC_OBJNAME) - -tclTestObj.${OBJEXT}: tclTestObj.c - $(CC) -c $(CC_SWITCHES) $(DEPARG) $(CC_OBJNAME) - -tclWinTest.${OBJEXT}: tclWinTest.c - $(CC) -c $(CC_SWITCHES) $(DEPARG) $(CC_OBJNAME) - -tclAppInit.${OBJEXT} : tclAppInit.c - $(CC) -c $(CC_SWITCHES) $(DEPARG) $(CC_OBJNAME) - -# The following objects should be built using the stub interfaces - -tclWinReg.${OBJEXT} : tclWinReg.c - $(CC) -c $(CC_SWITCHES) -DUSE_TCL_STUBS $(DEPARG) $(CC_OBJNAME) - -tclWinDde.${OBJEXT} : tclWinDde.c - $(CC) -c $(CC_SWITCHES) -DUSE_TCL_STUBS $(DEPARG) $(CC_OBJNAME) - -# The following objects are part of the stub library and should not -# be built as DLL objects but none of the symbols should be exported - -tclStubLib.${OBJEXT}: tclStubLib.c - $(CC) -c $(CC_SWITCHES) -DSTATIC_BUILD $(DEPARG) $(CC_OBJNAME) - - -# Implicit rule for all object files that will end up in the Tcl library - -.c.${OBJEXT}: - $(CC) -c $(CC_SWITCHES) -DBUILD_tcl ${DEPARG} $(CC_OBJNAME) - -.rc.$(RES): - $(RC) @RC_OUT@ $@ @RC_TYPE@ @RC_INCLUDE@ "$(GENERIC_DIR_NATIVE)" @RC_INCLUDE@ "$(WIN_DIR_NATIVE)" $(DEPARG) - -install: all install-binaries install-libraries install-doc - -install-binaries: - @$(MKDIR) -p "$(BIN_INSTALL_DIR)" - @$(MKDIR) -p "$(LIB_INSTALL_DIR)" - $(COPY) tclConfig.sh $(LIB_INSTALL_DIR)/tclConfig.sh - @for i in dde1.1 reg1.0; \ - do \ - if [ ! -d $(LIB_INSTALL_DIR)/$$i ] ; then \ - echo "Making directory $(LIB_INSTALL_DIR)/$$i"; \ - $(MKDIR) $(LIB_INSTALL_DIR)/$$i; \ - else true; \ - fi; \ - done; - @for i in $(TCL_DLL_FILE) $(TCLSH) $(PIPE_DLL_FILE); \ - do \ - if [ -f $$i ]; then \ - echo "Installing $$i"; \ - $(COPY) $$i "$(BIN_INSTALL_DIR)"; \ - fi; \ - done - @for i in $(TCL_LIB_FILE) $(TCL_STUB_LIB_FILE); \ - do \ - if [ -f $$i ]; then \ - echo "Installing $$i"; \ - $(COPY) $$i "$(LIB_INSTALL_DIR)"; \ - fi; \ - done - @if [ -f $(DDE_DLL_FILE) ]; then \ - echo installing $(DDE_DLL_FILE); \ - $(COPY) $(DDE_DLL_FILE) $(LIB_INSTALL_DIR)/dde1.1; \ - $(COPY) $(ROOT_DIR)/library/dde1.1/pkgIndex.tcl $(LIB_INSTALL_DIR)/dde1.1; \ - fi - @if [ -f $(DDE_LIB_FILE) ]; then \ - echo installing $(DDE_LIB_FILE); \ - $(COPY) $(DDE_LIB_FILE) $(LIB_INSTALL_DIR)/dde1.1; \ - fi - @if [ -f $(REG_DLL_FILE) ]; then \ - echo installing $(REG_DLL_FILE); \ - $(COPY) $(REG_DLL_FILE) $(LIB_INSTALL_DIR)/reg1.0; \ - $(COPY) $(ROOT_DIR)/library/reg1.0/pkgIndex.tcl $(LIB_INSTALL_DIR)/reg1.0; \ - fi - @if [ -f $(REG_LIB_FILE) ]; then \ - echo installing $(REG_LIB_FILE); \ - $(COPY) $(REG_LIB_FILE) $(LIB_INSTALL_DIR)/reg1.0; \ - fi - -install-libraries: - @for i in $(prefix)/lib $(INCLUDE_INSTALL_DIR) \ - $(SCRIPT_INSTALL_DIR); \ - do \ - if [ ! -d $$i ] ; then \ - echo "Making directory $$i"; \ - $(MKDIR) $$i; \ - else true; \ - fi; \ - done; - @for i in http1.0 http2.3 opt0.4 encoding msgcat1.0 tcltest1.0; \ - do \ - if [ ! -d $(SCRIPT_INSTALL_DIR)/$$i ] ; then \ - echo "Making directory $(SCRIPT_INSTALL_DIR)/$$i"; \ - $(MKDIR) $(SCRIPT_INSTALL_DIR)/$$i; \ - else true; \ - fi; \ - done; - @echo "Installing header files"; - @for i in "$(GENERIC_DIR)/tcl.h" "$(GENERIC_DIR)/tclDecls.h" ; \ - do \ - $(COPY) "$$i" "$(INCLUDE_INSTALL_DIR)"; \ - done; - @echo "Installing library files to $(SCRIPT_INSTALL_DIR)"; - @for i in $(ROOT_DIR)/library/*.tcl $(ROOT_DIR)/library/tclIndex; \ - do \ - $(COPY) "$$i" "$(SCRIPT_INSTALL_DIR)"; \ - done; - @for i in http2.3 http1.0 opt0.4 msgcat1.0 tcltest1.0; \ - do \ - echo "Installing library $$i directory"; \ - for j in $(ROOT_DIR)/library/$$i/*.tcl; \ - do \ - $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/$$i"; \ - done; \ - done; - @echo "Installing encodings" - @for i in $(ROOT_DIR)/library/encoding/*.enc ; do \ - $(COPY) "$$i" "$(SCRIPT_INSTALL_DIR)/encoding"; \ - done; - -install-doc: - -test: binaries $(TCLTEST) - TCL_LIBRARY="$(LIBRARY_DIR)"; export TCL_LIBRARY; \ - ./$(TCLTEST) "$(ROOT_DIR_NATIVE)/tests/all.tcl" $(TESTFLAGS) \ - | ./$(CAT32) - -# Useful target to launch a built tcltest with the proper path,... -runtest: tcltest - @TCL_LIBRARY="$(LIBRARY_DIR)"; export TCL_LIBRARY; \ - ./tcltest - -depend: - -Makefile: $(SRC_DIR)/Makefile.in - ./config.status - -cleanhelp: - $(RM) *.hlp *.cnt *.GID *.rtf man2tcl.exe - -clean: cleanhelp - $(RM) *.lib *.a *.exp *.dll *.$(RES) *.${OBJEXT} *~ \#* TAGS a.out - $(RM) $(TCLSH) $(TCLTEST) $(CAT32) - $(RM) *.pch *.ilk *.pdb - -distclean: clean - $(RM) Makefile config.status config.cache config.log tclConfig.sh \ - tcl.hpj - -# -# Regenerate the stubs files. -# - -$(GENERIC_DIR)/tclStubInit.c: $(GENERIC_DIR)/tcl.decls \ - $(GENERIC_DIR)/tclInt.decls - @TCL_LIBRARY="$(ROOT_DIR_NATIVE)/library"; export TCL_LIBRARY; \ - $(TCLSH) "$(ROOT_DIR_NATIVE)\tools\genStubs.tcl" \ - "$(GENERIC_DIR_NATIVE)" \ - "$(GENERIC_DIR_NATIVE)\tcl.decls" \ - "$(GENERIC_DIR_NATIVE)\tclInt.decls" - -genstubs: - @TCL_LIBRARY="$(ROOT_DIR_NATIVE)/library"; export TCL_LIBRARY; \ - $(TCLSH) "$(ROOT_DIR_NATIVE)\tools\genStubs.tcl" \ - "$(GENERIC_DIR_NATIVE)" \ - "$(GENERIC_DIR_NATIVE)\tcl.decls" \ - "$(GENERIC_DIR_NATIVE)\tclInt.decls" diff --git a/win/README b/win/README deleted file mode 100644 index 3cda9e3..0000000 --- a/win/README +++ /dev/null @@ -1,71 +0,0 @@ -Tcl 8.3 for Windows - -by Scott Stanton -Scriptics Corporation -scott.stanton@scriptics.com - -RCS: @(#) $Id: README,v 1.16 2000/04/26 17:31:22 hobbs Exp $ - -1. Introduction ---------------- - -This is the directory where you configure and compile the Windows -version of Tcl. This directory also contains source files for Tcl -that are specific to Microsoft Windows. - -The information in this file is maintained on the web at: - http://dev.scriptics.com/doc/howto/compile.html#win - -2. Compiling Tcl ----------------- - -In order to compile Tcl for Windows, you need the following items: - - Tcl 8.3 Source Distribution (plus any patches) - - Visual C++ 2.x/4.x/5.x - -In practice, this release is built with Visual C++ 5.0 - -In the "win" subdirectory of the source release, you will find -"makefile.vc". This is the makefile Visual C++ compiler. You should -update the paths at the top of the file to reflect your system -configuration. Now you can use "make" (or "nmake" for VC++) to build -the tcl libraries and the tclsh executable. - -In order to use the binaries generated by these makefiles, you will -need to place the Tcl script library files someplace where Tcl can -find them. Tcl looks in one of following places for the library files: - - 1) The path specified in the environment variable "TCL_LIBRARY". - - 2) In the lib\tcl8.3 directory under the installation directory - as specified in the registry: - - HKEY_LOCAL_MACHINE\SOFTWARE\Scriptics\Tcl\8.3 - - 3) Relative to the directory containing the current .exe. - Tcl will look for a directory "..\lib\tcl8.3" relative to the - directory containing the currently running .exe. - -Note that in order to run tclsh83.exe, you must ensure that tcl83.dll -and tclpip83.dll are on your path, in the system directory, or in the -directory containing tclsh83.exe. - -Note: Tcl no longer provides support for Win32s. - -This page includes a lengthy discussion of compiler macros necessary -when compiling Tcl extensions that will be dynamically loaded. - -3. Test suite -------------- - -This distribution contains an extensive test suite for Tcl. Some of -the tests are timing dependent and will fail from time to time. If a -test is failing consistently, please send us a bug report with as much -detail as you can manage. Please use the online database at - http://dev.scriptics.com/ticket/ - -In order to run the test suite, you build the "test" target using the -appropriate makefile for your compiler. - diff --git a/win/README.binary b/win/README.binary deleted file mode 100644 index 7bdeca8..0000000 --- a/win/README.binary +++ /dev/null @@ -1,151 +0,0 @@ -Tcl/Tk 8.3 for Windows, Binary Distribution - -RCS: @(#) $Id: README.binary,v 1.19.2.1 2000/07/27 01:39:23 hobbs Exp $ - -1. Introduction ---------------- - -This directory contains the binary distribution of Tcl/Tk 8.3.2 for -Windows. It was compiled with Microsoft Visual C++ 5.0 using Win32 -API, so that it will run under Windows NT, 95, 98 and 2000. - -Tcl provides a powerful platform for creating integration applications -that tie together diverse applications, protocols, devices, and -frameworks. When paired with the Tk toolkit, Tcl provides the fastest -and most powerful way to create GUI applications that run on PCs, Unix, -and the Macintosh. Tcl can also be used for a variety of web-related -tasks and for creating powerful command languages for applications. - -Tcl is maintained, enhanced, and distributed freely as a service to the -Tcl community by Scriptics Corporation. - -2. Documentation ----------------- - -The official home for Tcl and Tk on the Web is at: - http://dev.scriptics.com - -The home page for the Tcl/Tk 8.3 release is - http://dev.scriptics.com/software/tcltk/8.3.html - -Detailed release notes can be found at - http://dev.scriptics.com/software/tcltk/relnotes/tcl8.3.2.txt - -Information about Tcl itself can be found at - http://dev.scriptics.com/scripting/ - -There are many Tcl books on the market. Most are listed at - http://dev.scriptics.com/resource/doc/books/ - -There are notes about compiling Tcl at - http://dev.scriptics.com/doc/howto/compile.html - -3. Installation ---------------- - -The binary release is distributed as a self-extracting archive called -tcl83.exe. The setup program which will prompt you for an -installation directory. It will create the installation heirarchy -under the specified directory, and install a wish application icon -under the program manager group of your choice. - -We are no longer supporting use of Tcl with 16-bit versions of -Windows. Microsoft has completely dropped support of the Win32s -subsystem. - -4. Linking against the binary release --------------------------------------- - -In order to link your applications against the .dll files shipped with -this release, you will need to use the appropriate .lib file for your -compiler. In the lib directory of the installation directory, there -are library files for the Microsoft Visual C++ compiler: - - tcl83.lib - tk83.lib - -5. Building dynamically loadable extensions --------------------------------------------- - -Please refer to the example dynamically loadable extension provided on -our ftp site: - - ftp://ftp.scriptics.com/pub/tcl/misc/example.zip - -This archive contains a template that you can use for building -extensions that will be loadable on Unix, Windows, and Macintosh -systems. - -6. Reporting Bugs ------------------ -If you have comments or bug reports for the Windows version of Tcl, -please use our online database at: - - http://dev.scriptics.com/ticket/ - -or post them to the newsgroup comp.lang.tcl. - -7. Tcl newsgroup ------------------ - -There is a network news group "comp.lang.tcl" intended for the exchange -of information about Tcl, Tk, and related applications. Feel free to use -the newsgroup both for general information questions and for bug reports. -We read the newsgroup and will attempt to fix bugs and problems reported -to it. - -When using comp.lang.tcl, please be sure that your e-mail return address -is correctly set in your postings. This allows people to respond directly -to you, rather than the entire newsgroup, for answers that are not of -general interest. A bad e-mail return address may prevent you from -getting answers to your questions. You may have to reconfigure your news -reading software to ensure that it is supplying valid e-mail addresses. - -8. Tcl contributed archive --------------------------- - -Many people have created exciting packages and applications based on Tcl -and/or Tk and made them freely available to the Tcl community. An archive -of these contributions is kept on the machine ftp.neosoft.com. You -can access the archive using anonymous FTP; the Tcl contributed archive is -in the directory "/pub/tcl". The archive also contains several FAQ -("frequently asked questions") documents that provide solutions to problems -that are commonly encountered by TCL newcomers. - -9. Tcl Resource Center ----------------------- -Visit http://dev.scritics.com/resource/ to see an annotated index of -many Tcl resources available on the World Wide Web. This includes -papers, books, and FAQs, as well as extensions, applications, binary -releases, and patches. You can contribute patches by sending them -to <patches@scriptics.com>. You can also recommend more URLs for the -resource center using the forms labeled "Add a Resource". - -10. Mailing lists ----------------- - -A couple of mailing lists have been set up to discuss Macintosh or -Windows related Tcl issues. In order to use these Mailing Lists you -must have access to the internet. To subscribe send a message to: - - wintcl-request@scriptics.com - mactcl-request@scriptics.com - -In the body of the message (the subject will be ignored) put: - - subscribe mactcl Joe Blow - -Replacing Joe Blow with your real name, of course. (Use wintcl -instead of mactcl if you're interested in the Windows list.) If you -would just like to receive more information about the list without -subscribing put the line: - - information mactcl - -in the body instead (or wintcl). There are also Special Interest -Groups (SIGs) setup for these topics and more at: - - http://dev.scriptics.com/ - - - diff --git a/win/aclocal.m4 b/win/aclocal.m4 deleted file mode 100644 index bc7540d..0000000 --- a/win/aclocal.m4 +++ /dev/null @@ -1 +0,0 @@ -builtin(include,tcl.m4) diff --git a/win/cat.c b/win/cat.c deleted file mode 100644 index cdd83a5..0000000 --- a/win/cat.c +++ /dev/null @@ -1,37 +0,0 @@ -/* - * cat.c -- - * - * Program used when testing tclWinPipe.c - * - * Copyright (c) 1996 by Sun Microsystems, Inc. - * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: cat.c,v 1.2 1998/09/14 18:40:19 stanton Exp $ - */ - -#include <stdio.h> -#include <io.h> -#include <string.h> - -int -main() -{ - char buf[1024]; - int n; - char *err; - - while (1) { - n = read(0, buf, sizeof(buf)); - if (n <= 0) { - break; - } - write(1, buf, n); - } - err = (sizeof(int) == 2) ? "stderr16" : "stderr32"; - write(2, err, strlen(err)); - - return 0; -} - diff --git a/win/configure.in b/win/configure.in deleted file mode 100644 index 0e3a421..0000000 --- a/win/configure.in +++ /dev/null @@ -1,189 +0,0 @@ -# This file is an input file used by the GNU "autoconf" program to -# generate the file "configure", which is run during Tcl installation -# to configure the system for the local environment. -# -# RCS: @(#) $Id: configure.in,v 1.20.2.2 2000/07/28 07:58:28 mo Exp $ - -AC_INIT(../generic/tcl.h) - -TCL_VERSION=8.3 -TCL_MAJOR_VERSION=8 -TCL_MINOR_VERSION=3 -TCL_PATCH_LEVEL=".2" -VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION - -if test "${prefix}" = "NONE"; then - prefix=/usr/local -fi -if test "${exec_prefix}" = "NONE"; then - exec_prefix=$prefix -fi - -#-------------------------------------------------------------------- -# Check whether --enable-gcc or --disable-gcc was given. Do this -# before AC_PROG_CC and AC_CYGWIN are called so the compiler can -# be fully tested by built-in autoconf tools. -#-------------------------------------------------------------------- - -SC_ENABLE_GCC - -#-------------------------------------------------------------------- -# Checks to see if the make progeam sets the $MAKE variable. -#-------------------------------------------------------------------- - -AC_PROG_MAKE_SET - -#-------------------------------------------------------------------- -# These two macros perform additinal compiler test. -#-------------------------------------------------------------------- - -AC_CYGWIN - -#-------------------------------------------------------------------- -# Determines the correct binary file extension (.o, .obj, .exe etc.) -#-------------------------------------------------------------------- - -AC_OBJEXT -AC_EXEEXT - -#-------------------------------------------------------------------- -# Check whether --enable-threads or --disable-threads was given. -#-------------------------------------------------------------------- - -SC_ENABLE_THREADS - -#-------------------------------------------------------------------- -# The statements below define a collection of symbols related to -# building libtcl as a shared library instead of a static library. -#-------------------------------------------------------------------- - -SC_ENABLE_SHARED - -#-------------------------------------------------------------------- -# The statements below define a collection of compile flags. This -# macro depends on the value of SHARED_BUILD, and should be called -# after SC_ENABLE_SHARED checks the configure switches. -#-------------------------------------------------------------------- - -SC_CONFIG_CFLAGS - -#-------------------------------------------------------------------- -# Set the default compiler switches based on the --enable-symbols -# option. This macro depends on C flags, and should be called -# after SC_CONFIG_CFLAGS macro is called. -#-------------------------------------------------------------------- - -SC_ENABLE_SYMBOLS - -CFLAGS=${CFLAGS_DEFAULT} -LDFLAGS=${LDFLAGS_DEFAULT} -TCL_DBGX=${DBGX} - -#-------------------------------------------------------------------- -# man2tcl needs this so that it can use errno.h -#-------------------------------------------------------------------- - -AC_CHECK_HEADER(errno.h, , MAN2TCLFLAGS="-DNO_ERRNO_H") -AC_SUBST(MAN2TCLFLAGS) - -#------------------------------------------------------------------------ -# tclConfig.sh refers to this by a different name -#------------------------------------------------------------------------ - -TCL_SHARED_BUILD=${SHARED_BUILD} - -#-------------------------------------------------------------------- -# Perform final evaluations of variables with possible substitutions. -#-------------------------------------------------------------------- - -TCL_SHARED_LIB_SUFFIX="\${NODOT_VERSION}${DLLSUFFIX}" -TCL_UNSHARED_LIB_SUFFIX="\${NODOT_VERSION}${LIBSUFFIX}" -TCL_EXPORT_FILE_SUFFIX="\${NODOT_VERSION}${LIBSUFFIX}" - -eval "TCL_SRC_DIR=\"`cd $srcdir/..; pwd`\"" - -eval "TCL_DLL_FILE=tcl${VER}${DLLSUFFIX}" - -eval "TCL_LIB_FILE=${LIBPREFIX}tcl$VER${LIBSUFFIX}" -# FIMXE: These variables decls are missing -#TCL_LIB_FLAG -#TCL_BUILD_LIB_SPEC -#TCL_LIB_SPEC - -eval "TCL_STUB_LIB_FILE=\"${LIBPREFIX}tclstub${VER}${LIBSUFFIX}\"" -eval "TCL_STUB_LIB_FLAG=\"-ltclstub${VER}${TCL_DBGX}\"" -eval "TCL_BUILD_STUB_LIB_SPEC=\"-L`pwd` ${TCL_STUB_LIB_FLAG}\"" -eval "TCL_STUB_LIB_SPEC=\"-L${exec_prefix}/lib ${TCL_STUB_LIB_FLAG}\"" -eval "TCL_BUILD_STUB_LIB_PATH=\"`pwd`/${TCL_STUB_LIB_FILE}\"" -eval "TCL_STUB_LIB_PATH=\"${exec_prefix}/lib/${TCL_STUB_LIB_FILE}\"" - -eval "DLLSUFFIX=${DLLSUFFIX}" -eval "LIBPREFIX=${LIBPREFIX}" -eval "LIBSUFFIX=${LIBSUFFIX}" -eval "EXESUFFIX=${EXESUFFIX}" - -CFG_TCL_SHARED_LIB_SUFFIX=${TCL_SHARED_LIB_SUFFIX} -CFG_TCL_UNSHARED_LIB_SUFFIX=${TCL_UNSHARED_LIB_SUFFIX} -CFG_TCL_EXPORT_FILE_SUFFIX=${TCL_EXPORT_FILE_SUFFIX} - -AC_SUBST(TCL_VERSION) -AC_SUBST(TCL_MAJOR_VERSION) -AC_SUBST(TCL_MINOR_VERSION) -AC_SUBST(TCL_PATCH_LEVEL) -AC_SUBST(TCL_LIB_FILE) -AC_SUBST(TCL_LIB_FLAG) -AC_SUBST(TCL_DLL_FILE) -AC_SUBST(TCL_STUB_LIB_FILE) -AC_SUBST(TCL_STUB_LIB_FLAG) -AC_SUBST(TCL_BUILD_STUB_LIB_SPEC) -AC_SUBST(TCL_STUB_LIB_SPEC) -AC_SUBST(TCL_BUILD_STUB_LIB_PATH) -AC_SUBST(TCL_STUB_LIB_PATH) - -AC_SUBST(TCL_SRC_DIR) -AC_SUBST(TCL_BIN_DIR) -AC_SUBST(TCL_DBGX) -AC_SUBST(CFG_TCL_SHARED_LIB_SUFFIX) -AC_SUBST(CFG_TCL_UNSHARED_LIB_SUFFIX) -AC_SUBST(CFG_TCL_EXPORT_FILE_SUFFIX) -AC_SUBST(TCL_SHARED_BUILD) - -AC_SUBST(PATHTYPE) -AC_SUBST(CYGPATH) -AC_SUBST(VPSEP) -AC_SUBST(CFLAGS_DEBUG) -AC_SUBST(CFLAGS_OPTIMIZE) -AC_SUBST(CFLAGS_WARNING) -AC_SUBST(EXTRA_CFLAGS) -AC_SUBST(STLIB_LD) -AC_SUBST(SHLIB_LD) -AC_SUBST(SHLIB_LD_LIBS) -AC_SUBST(SHLIB_CFLAGS) -AC_SUBST(SHLIB_SUFFIX) -AC_SUBST(CC_OBJNAME) -AC_SUBST(CC_EXENAME) -AC_SUBST(LDFLAGS) -AC_SUBST(LDFLAGS_DEBUG) -AC_SUBST(LDFLAGS_OPTIMIZE) -AC_SUBST(LDFLAGS_CONSOLE) -AC_SUBST(LDFLAGS_WINDOW) -AC_SUBST(AR) -AC_SUBST(RANLIB) -AC_SUBST(RC) -AC_SUBST(RC_OUT) -AC_SUBST(RC_TYPE) -AC_SUBST(RC_INCLUDE) -AC_SUBST(RES) -AC_SUBST(LIBS) -AC_SUBST(LIBS_GUI) -AC_SUBST(DLLSUFFIX) -AC_SUBST(LIBPREFIX) -AC_SUBST(LIBSUFFIX) -AC_SUBST(EXESUFFIX) -AC_SUBST(LIBRARIES) -AC_SUBST(MAKE_LIB) -AC_SUBST(POST_MAKE_LIB) -AC_SUBST(MAKE_DLL) -AC_SUBST(MAKE_EXE) - -AC_OUTPUT(Makefile tclConfig.sh tcl.hpj) diff --git a/win/makefile.vc b/win/makefile.vc deleted file mode 100644 index 72ce802..0000000 --- a/win/makefile.vc +++ /dev/null @@ -1,524 +0,0 @@ -# Visual C++ 2.x and 4.0 makefile -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# Copyright (c) 1995-1996 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. -# -# RCS: @(#) $Id: makefile.vc,v 1.50.2.1 2000/07/27 01:39:24 hobbs Exp $ - -# Does not depend on the presence of any environment variables in -# order to compile tcl; all needed information is derived from -# location of the compiler directories. - -# -# Project directories -# -# ROOT = top of source tree -# -# TOOLS32 = location of VC++ 32-bit development tools. Note that the -# VC++ 2.0 header files are broken, so you need to use the -# ones that come with the developer network CD's, or later -# versions of VC++. -# -# INSTALLDIR = where the install- targets should copy the binaries and -# support files -# - -# Set this to the appropriate value of /MACHINE: for your platform -MACHINE = IX86 - -ROOT = .. -INSTALLDIR = c:\Progra~1\Tcl - -!IF "$(MACHINE)" == "IA64" -TOOLS32 = c:\ia64sdk17 -TOOLS32_rc = c:\ia64sdk17 -!ELSE -TOOLS32 = c:\Progra~1\devstudio\vc -TOOLS32_rc = c:\Progra~1\devstudio\sharedide -!ENDIF - -# Uncomment the following line to compile with thread support -#THREADDEFINES = -DTCL_THREADS=1 - -# Set NODEBUG to 0 to compile with symbols -NODEBUG = 1 - -# The following defines can be used to control the amount of debugging -# code that is added to the compilation. -# -# -DTCL_MEM_DEBUG Enables the debugging memory allocator. -# -DTCL_COMPILE_DEBUG Enables byte compilation logging. -# -DTCL_COMPILE_STATS Enables byte compilation statistics gathering. -# -DUSE_TCLALLOC=0 Disables the Tcl memory allocator in favor -# of the native malloc implementation. This is -# needed when using Purify. -# -#DEBUGDEFINES = -DTCL_MEM_DEBUG -DTCL_COMPILE_DEBUG -DTCL_COMPILE_STATS -#DEBUGDEFINES = -DUSE_TCLALLOC=0 - -###################################################################### -# Do not modify below this line -###################################################################### - -NAMEPREFIX = tcl -STUBPREFIX = $(NAMEPREFIX)stub -DOTVERSION = 8.3 -VERSION = 83 - -BINROOT = . -!IF "$(NODEBUG)" == "1" -TMPDIRNAME = Release -DBGX = -!ELSE -TMPDIRNAME = Debug -DBGX = d -!ENDIF -TMPDIR = $(BINROOT)\$(TMPDIRNAME) -OUTDIRNAME = $(TMPDIRNAME) -OUTDIR = $(TMPDIR) - -TCLLIB = $(OUTDIR)\$(NAMEPREFIX)$(VERSION)$(DBGX).lib -TCLDLLNAME = $(NAMEPREFIX)$(VERSION)$(DBGX).dll -TCLDLL = $(OUTDIR)\$(TCLDLLNAME) - -TCLSTUBLIBNAME = $(STUBPREFIX)$(VERSION)$(DBGX).lib -TCLSTUBLIB = $(OUTDIR)\$(TCLSTUBLIBNAME) - -TCLPLUGINLIB = $(OUTDIR)\$(NAMEPREFIX)$(VERSION)p$(DBGX).lib -TCLPLUGINDLLNAME= $(NAMEPREFIX)$(VERSION)p$(DBGX).dll -TCLPLUGINDLL = $(OUTDIR)\$(TCLPLUGINDLLNAME) -TCLSH = $(OUTDIR)\$(NAMEPREFIX)sh$(VERSION)$(DBGX).exe -TCLSHP = $(OUTDIR)\$(NAMEPREFIX)shp$(VERSION)$(DBGX).exe -TCLPIPEDLLNAME = $(NAMEPREFIX)pip$(VERSION)$(DBGX).dll -TCLPIPEDLL = $(OUTDIR)\$(TCLPIPEDLLNAME) -TCLREGDLLNAME = $(NAMEPREFIX)reg$(VERSION)$(DBGX).dll -TCLREGDLL = $(OUTDIR)\$(TCLREGDLLNAME) -TCLDDEDLLNAME = $(NAMEPREFIX)dde$(VERSION)$(DBGX).dll -TCLDDEDLL = $(OUTDIR)\$(TCLDDEDLLNAME) -TCLTEST = $(OUTDIR)\$(NAMEPREFIX)test.exe -CAT32 = $(TMPDIR)\cat32.exe -RMDIR = .\rmd.bat -MKDIR = .\mkd.bat -RM = del - -LIB_INSTALL_DIR = $(INSTALLDIR)\lib -BIN_INSTALL_DIR = $(INSTALLDIR)\bin -SCRIPT_INSTALL_DIR = $(INSTALLDIR)\lib\tcl$(DOTVERSION) -INCLUDE_INSTALL_DIR = $(INSTALLDIR)\include - -TCLSHOBJS = \ - $(TMPDIR)\tclAppInit.obj - -TCLTESTOBJS = \ - $(TMPDIR)\tclTest.obj \ - $(TMPDIR)\tclTestObj.obj \ - $(TMPDIR)\tclTestProcBodyObj.obj \ - $(TMPDIR)\tclThreadTest.obj \ - $(TMPDIR)\tclWinTest.obj \ - $(TMPDIR)\testMain.obj - -TCLOBJS = \ - $(TMPDIR)\regcomp.obj \ - $(TMPDIR)\regexec.obj \ - $(TMPDIR)\regfree.obj \ - $(TMPDIR)\regerror.obj \ - $(TMPDIR)\strftime.obj \ - $(TMPDIR)\tclAlloc.obj \ - $(TMPDIR)\tclAsync.obj \ - $(TMPDIR)\tclBasic.obj \ - $(TMPDIR)\tclBinary.obj \ - $(TMPDIR)\tclCkalloc.obj \ - $(TMPDIR)\tclClock.obj \ - $(TMPDIR)\tclCmdAH.obj \ - $(TMPDIR)\tclCmdIL.obj \ - $(TMPDIR)\tclCmdMZ.obj \ - $(TMPDIR)\tclCompCmds.obj \ - $(TMPDIR)\tclCompExpr.obj \ - $(TMPDIR)\tclCompile.obj \ - $(TMPDIR)\tclDate.obj \ - $(TMPDIR)\tclEncoding.obj \ - $(TMPDIR)\tclEnv.obj \ - $(TMPDIR)\tclEvent.obj \ - $(TMPDIR)\tclExecute.obj \ - $(TMPDIR)\tclFCmd.obj \ - $(TMPDIR)\tclFileName.obj \ - $(TMPDIR)\tclGet.obj \ - $(TMPDIR)\tclHash.obj \ - $(TMPDIR)\tclHistory.obj \ - $(TMPDIR)\tclIndexObj.obj \ - $(TMPDIR)\tclInterp.obj \ - $(TMPDIR)\tclIO.obj \ - $(TMPDIR)\tclIOCmd.obj \ - $(TMPDIR)\tclIOGT.obj \ - $(TMPDIR)\tclIOSock.obj \ - $(TMPDIR)\tclIOUtil.obj \ - $(TMPDIR)\tclLink.obj \ - $(TMPDIR)\tclLiteral.obj \ - $(TMPDIR)\tclListObj.obj \ - $(TMPDIR)\tclLoad.obj \ - $(TMPDIR)\tclMain.obj \ - $(TMPDIR)\tclNamesp.obj \ - $(TMPDIR)\tclNotify.obj \ - $(TMPDIR)\tclObj.obj \ - $(TMPDIR)\tclPanic.obj \ - $(TMPDIR)\tclParse.obj \ - $(TMPDIR)\tclParseExpr.obj \ - $(TMPDIR)\tclPipe.obj \ - $(TMPDIR)\tclPkg.obj \ - $(TMPDIR)\tclPosixStr.obj \ - $(TMPDIR)\tclPreserve.obj \ - $(TMPDIR)\tclProc.obj \ - $(TMPDIR)\tclRegexp.obj \ - $(TMPDIR)\tclResolve.obj \ - $(TMPDIR)\tclResult.obj \ - $(TMPDIR)\tclScan.obj \ - $(TMPDIR)\tclStringObj.obj \ - $(TMPDIR)\tclStubInit.obj \ - $(TMPDIR)\tclStubLib.obj \ - $(TMPDIR)\tclThread.obj \ - $(TMPDIR)\tclTimer.obj \ - $(TMPDIR)\tclUtf.obj \ - $(TMPDIR)\tclUtil.obj \ - $(TMPDIR)\tclVar.obj \ - $(TMPDIR)\tclWin32Dll.obj \ - $(TMPDIR)\tclWinChan.obj \ - $(TMPDIR)\tclWinConsole.obj \ - $(TMPDIR)\tclWinSerial.obj \ - $(TMPDIR)\tclWinError.obj \ - $(TMPDIR)\tclWinFCmd.obj \ - $(TMPDIR)\tclWinFile.obj \ - $(TMPDIR)\tclWinInit.obj \ - $(TMPDIR)\tclWinLoad.obj \ - $(TMPDIR)\tclWinMtherr.obj \ - $(TMPDIR)\tclWinNotify.obj \ - $(TMPDIR)\tclWinPipe.obj \ - $(TMPDIR)\tclWinSock.obj \ - $(TMPDIR)\tclWinThrd.obj \ - $(TMPDIR)\tclWinTime.obj - -TCLSTUBOBJS = $(TMPDIR)\tclStubLib.obj \ - -cc32 = "$(TOOLS32)\bin\cl.exe" -link32 = "$(TOOLS32)\bin\link.exe" -rc32 = "$(TOOLS32_rc)\bin\rc.exe" -include32 = -I"$(TOOLS32)\include" -libpath32 = /LIBPATH:"$(TOOLS32)\lib" -lib32 = "$(TOOLS32)\bin\lib.exe" - -WINDIR = $(ROOT)\win -GENERICDIR = $(ROOT)\generic - -TCL_INCLUDES = -I"$(WINDIR)" -I"$(GENERICDIR)" -TCL_DEFINES = $(DEBUGDEFINES) $(THREADDEFINES) - -###################################################################### -# Compile flags -###################################################################### - -!IF "$(NODEBUG)" == "1" -# This cranks the optimization level to maximize speed -cdebug = -O2 -Gs -GD -!ELSE -!IF "$(MACHINE)" == "IA64" -cdebug = -Od -Zi -!ELSE -cdebug = -Z7 -Od -WX -!ENDIF -!ENDIF - -# declarations common to all compiler options -cflags = -c -W3 -nologo -Fp$(TMPDIR)\ -YX -cvarsdll = -MD$(DBGX) - -TCL_CFLAGS = $(cdebug) $(cflags) $(cvarsdll) $(include32) \ - $(TCL_INCLUDES) $(TCL_DEFINES) -CON_CFLAGS = $(cdebug) $(cflags) $(include32) -DCONSOLE - -###################################################################### -# Link flags -###################################################################### - -!IF "$(NODEBUG)" == "1" -ldebug = /RELEASE -!ELSE -ldebug = -debug:full -debugtype:cv -!ENDIF - -# declarations common to all linker options -lflags = /NODEFAULTLIB /NOLOGO /MACHINE:$(MACHINE) $(libpath32) - -# declarations for use on Intel i386, i486, and Pentium systems -!IF "$(MACHINE)" == "IX86" -DLLENTRY = @12 -dlllflags = $(lflags) -entry:_DllMainCRTStartup$(DLLENTRY) -dll -!ELSE -!IF "$(MACHINE)" == "IA64" -DLLENTRY = @12 -dlllflags = $(lflags) -dll -!ELSE -dlllflags = $(lflags) -entry:_DllMainCRTStartup$(DLLENTRY) -dll -!ENDIF -!ENDIF - -conlflags = $(lflags) -subsystem:console -entry:mainCRTStartup -guilflags = $(lflags) -subsystem:windows -entry:WinMainCRTStartup - -!IF "$(MACHINE)" == "PPC" -libc = libc$(DBGX).lib -libcdll = crtdll$(DBGX).lib -!ELSE -libc = libc$(DBGX).lib oldnames.lib -libcdll = msvcrt$(DBGX).lib oldnames.lib -!ENDIF - -baselibs = kernel32.lib $(optlibs) advapi32.lib user32.lib -winlibs = $(baselibs) gdi32.lib comdlg32.lib winspool.lib - -guilibs = $(libc) $(winlibs) -conlibs = $(libc) $(baselibs) -guilibsdll = $(libcdll) $(winlibs) -conlibsdll = $(libcdll) $(baselibs) - -###################################################################### -# Project specific targets -###################################################################### - -release: setup $(TCLSH) dlls -dlls: setup $(TCLPIPEDLL) $(TCLREGDLL) $(TCLDDEDLL) -all: setup $(TCLSH) dlls $(CAT32) -tcltest: setup $(TCLTEST) dlls $(CAT32) -plugin: setup $(TCLPLUGINDLL) $(TCLSHP) -install: install-binaries install-libraries -test: setup $(TCLTEST) dlls $(CAT32) - set TCL_LIBRARY=$(ROOT)/library - $(TCLTEST) $(ROOT)/tests/all.tcl - -setup: - @$(MKDIR) $(TMPDIR) - @$(MKDIR) $(OUTDIR) - -$(TCLLIB): $(TCLDLL) - -$(TCLDLL): $(TCLOBJS) $(TMPDIR)\tcl.res - $(link32) $(ldebug) $(dlllflags) \ - -out:$@ $(TMPDIR)\tcl.res $(guilibsdll) @<< -$(TCLOBJS) -<< - -$(TCLSTUBLIB): $(TCLSTUBOBJS) - $(lib32) /out:$@ $(TCLSTUBOBJS) - -$(TCLPLUGINLIB): $(TCLPLUGINDLL) - -$(TCLPLUGINDLL): $(TCLOBJS) $(TMPDIR)\tcl.res - $(link32) $(ldebug) $(dlllflags) \ - -out:$@ $(TMPDIR)\tcl.res $(guilibsdll) @<< -$(TCLOBJS) -<< - -$(TCLSH): $(TCLSHOBJS) $(TCLLIB) $(TMPDIR)\tclsh.res - $(link32) $(ldebug) $(conlflags) $(TMPDIR)\tclsh.res -stack:2300000 \ - -out:$@ $(conlibsdll) $(TCLLIB) $(TCLSHOBJS) - -$(TCLSHP): $(TCLSHOBJS) $(TCLPLUGINLIB) $(TMPDIR)\tclsh.res - $(link32) $(ldebug) $(conlflags) $(TMPDIR)\tclsh.res -stack:2300000 \ - -out:$@ $(conlibsdll) $(TCLPLUGINLIB) $(TCLSHOBJS) - -$(TCLTEST): $(TCLTESTOBJS) $(TCLLIB) $(TMPDIR)\tclsh.res - $(link32) $(ldebug) $(conlflags) $(TMPDIR)\tclsh.res -stack:2300000 \ - -out:$@ $(conlibsdll) $(TCLLIB) $(TCLTESTOBJS) - -$(TCLPIPEDLL): $(WINDIR)\stub16.c - $(cc32) $(CON_CFLAGS) -Fo$(TMPDIR)\ $(WINDIR)\stub16.c - $(link32) $(ldebug) $(conlflags) -out:$@ $(TMPDIR)\stub16.obj $(guilibs) - -$(TCLDDEDLL): $(TMPDIR)\tclWinDde.obj $(TCLSTUBLIB) - $(link32) $(ldebug) $(dlllflags) -out:$@ $(TMPDIR)\tclWinDde.obj \ - $(conlibsdll) $(TCLSTUBLIB) - -$(TCLREGDLL): $(TMPDIR)\tclWinReg.obj $(TCLSTUBLIB) - $(link32) $(ldebug) $(dlllflags) -out:$@ $(TMPDIR)\tclWinReg.obj \ - $(conlibsdll) $(TCLSTUBLIB) - -$(CAT32): $(WINDIR)\cat.c - $(cc32) $(CON_CFLAGS) -Fo$(TMPDIR)\ $? - $(link32) $(conlflags) -out:$@ -stack:16384 $(TMPDIR)\cat.obj $(conlibs) - -install-binaries: $(TCLSH) - $(MKDIR) "$(BIN_INSTALL_DIR)" - $(MKDIR) "$(LIB_INSTALL_DIR)" - @echo installing $(TCLDLLNAME) - @copy "$(TCLDLL)" "$(BIN_INSTALL_DIR)" - @copy "$(TCLLIB)" "$(LIB_INSTALL_DIR)" - @echo installing "$(TCLSH)" - @copy "$(TCLSH)" "$(BIN_INSTALL_DIR)" - @echo installing $(TCLPIPEDLLNAME) - @copy "$(TCLPIPEDLL)" "$(BIN_INSTALL_DIR)" - @echo installing $(TCLSTUBLIBNAME) - @copy "$(TCLSTUBLIB)" "$(LIB_INSTALL_DIR)" - -install-libraries: - -@$(MKDIR) "$(LIB_INSTALL_DIR)" - -@$(MKDIR) "$(INCLUDE_INSTALL_DIR)" - -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)" - @echo installing http1.0 - -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\http1.0" - -@copy "$(ROOT)\library\http1.0\http.tcl" "$(SCRIPT_INSTALL_DIR)\http1.0" - -@copy "$(ROOT)\library\http1.0\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\http1.0" - @echo installing http2.3 - -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\http2.3" - -@copy "$(ROOT)\library\http2.3\http.tcl" "$(SCRIPT_INSTALL_DIR)\http2.3" - -@copy "$(ROOT)\library\http2.3\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\http2.3" - @echo installing opt0.4 - -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\opt0.4" - -@copy "$(ROOT)\library\opt0.4\optparse.tcl" "$(SCRIPT_INSTALL_DIR)\opt0.4" - -@copy "$(ROOT)\library\opt0.4\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\opt0.4" - @echo installing msgcat1.0 - -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\msgcat1.0" - -@copy "$(ROOT)\library\msgcat1.0\msgcat.tcl" "$(SCRIPT_INSTALL_DIR)\msgcat1.0" - -@copy "$(ROOT)\library\msgcat1.0\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\msgcat1.0" - @echo installing $(TCLDDEDLLNAME) - -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\dde1.1" - -@copy "$(TCLDDEDLL)" "$(SCRIPT_INSTALL_DIR)\dde1.1" - -@copy "$(ROOT)\library\dde1.1\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\dde1.1" - @echo installing $(TCLREGDLLNAME) - -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\reg1.0" - -@copy "$(TCLREGDLL)" "$(SCRIPT_INSTALL_DIR)\reg1.0" - -@copy "$(ROOT)\library\reg1.0\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\reg1.0" - @echo installing encoding files - -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\encoding" - -@copy "$(ROOT)\library\encoding\*.enc" "$(SCRIPT_INSTALL_DIR)\encoding" - @echo installing library files - -@copy "$(GENERICDIR)\tcl.h" "$(INCLUDE_INSTALL_DIR)" - -@copy "$(GENERICDIR)\tclDecls.h" "$(INCLUDE_INSTALL_DIR)" - -@copy "$(ROOT)\library\history.tcl" "$(SCRIPT_INSTALL_DIR)" - -@copy "$(ROOT)\library\init.tcl" "$(SCRIPT_INSTALL_DIR)" - -@copy "$(ROOT)\library\ldAout.tcl" "$(SCRIPT_INSTALL_DIR)" - -@copy "$(ROOT)\library\parray.tcl" "$(SCRIPT_INSTALL_DIR)" - -@copy "$(ROOT)\library\safe.tcl" "$(SCRIPT_INSTALL_DIR)" - -@copy "$(ROOT)\library\tclIndex" "$(SCRIPT_INSTALL_DIR)" - -@copy "$(ROOT)\library\package.tcl" "$(SCRIPT_INSTALL_DIR)" - -@copy "$(ROOT)\library\word.tcl" "$(SCRIPT_INSTALL_DIR)" - -@copy "$(ROOT)\library\auto.tcl" "$(SCRIPT_INSTALL_DIR)" - -# -# Regenerate the stubs files. -# - -genstubs: - tclsh$(VERSION) $(ROOT)\tools\genStubs.tcl $(GENERICDIR) \ - $(GENERICDIR)\tcl.decls $(GENERICDIR)\tclInt.decls - -# -# Regenerate the windows help files. -# - -TCLTOOLS = $(ROOT)/tools -MAN2TCL = $(TCLTOOLS)/man2tcl -TCLRTF = $(TCLTOOLS)/tcl.rtf -TCLHPJ = $(TCLTOOLS)/tcl.hpj -MAN2HELP = $(TCLTOOLS)/man2help.tcl -HCRTF = $(TOOLS32)/bin/hcrtf.exe - -winhelp: $(TCLRTF) - cd $(TCLTOOLS) - start /wait $(HCRTF) -xn $(TCLHPJ) - -$(MAN2TCL).exe: $(MAN2TCL).obj - cd $(TCLTOOLS) - $(cc32) /nologo /G4 /ML /O2 $(MAN2TCL).c - -$(TCLRTF): $(MAN2TCL).exe $(TCLSH) - cd $(TCLTOOLS) - ..\win\$(TCLSH) $(MAN2HELP) $(NAMEPREFIX) $(VERSION) $(ROOT)/doc ../../tk$(DOTVERSION)/doc - -# -# Special case object file targets -# - -$(TMPDIR)\tclWinInit.obj: $(WINDIR)\tclWinInit.c - $(cc32) -DBUILD_tcl $(TCL_CFLAGS) $(EXTFLAGS) -Fo$(TMPDIR)\ $? - -$(TMPDIR)\testMain.obj: $(WINDIR)\tclAppInit.c - $(cc32) $(TCL_CFLAGS) -DTCL_TEST -Fo$(TMPDIR)\testMain.obj $? - -$(TMPDIR)\tclTest.obj: $(GENERICDIR)\tclTest.c - $(cc32) $(TCL_CFLAGS) -Fo$@ $? - -$(TMPDIR)\tclTestObj.obj: $(GENERICDIR)\tclTestObj.c - $(cc32) $(TCL_CFLAGS) -Fo$@ $? - -$(TMPDIR)\tclWinTest.obj: $(WINDIR)\tclWinTest.c - $(cc32) $(TCL_CFLAGS) -Fo$@ $? - -$(TMPDIR)\tclAppInit.obj : $(WINDIR)\tclAppInit.c - $(cc32) $(TCL_CFLAGS) -Fo$@ $? - -# The following objects should be built using the stub interfaces - -$(TMPDIR)\tclWinReg.obj : $(WINDIR)\tclWinReg.c - $(cc32) $(TCL_CFLAGS) -DUSE_TCL_STUBS -Fo$@ $? - -$(TMPDIR)\tclWinDde.obj : $(WINDIR)\tclWinDde.c - $(cc32) $(TCL_CFLAGS) -DUSE_TCL_STUBS -Fo$@ $? - -# The following objects are part of the stub library and should not -# be built as DLL objects but none of the symbols should be exported - -$(TMPDIR)\tclStubLib.obj : $(GENERICDIR)\tclStubLib.c - $(cc32) $(TCL_CFLAGS) -DSTATIC_BUILD -Fo$@ $? - - -# Dedependency rules - -$(GENERICDIR)\regcomp.c: \ - $(GENERICDIR)\regguts.h \ - $(GENERICDIR)\regc_lex.c \ - $(GENERICDIR)\regc_color.c \ - $(GENERICDIR)\regc_nfa.c \ - $(GENERICDIR)\regc_cvec.c \ - $(GENERICDIR)\regc_locale.c -$(GENERICDIR)\regcustom.h: \ - $(GENERICDIR)\tclInt.h \ - $(GENERICDIR)\tclPort.h \ - $(GENERICDIR)\regex.h -$(GENERICDIR)\regexec.c: \ - $(GENERICDIR)\rege_dfa.c \ - $(GENERICDIR)\regguts.h -$(GENERICDIR)\regerror.c: $(GENERICDIR)\regguts.h -$(GENERICDIR)\regfree.c: $(GENERICDIR)\regguts.h -$(GENERICDIR)\regfronts.c: $(GENERICDIR)\regguts.h -$(GENERICDIR)\regguts.h: $(GENERICDIR)\regcustom.h - -# -# Implicit rules -# - -{$(WINDIR)}.c{$(TMPDIR)}.obj: - $(cc32) -DBUILD_tcl $(TCL_CFLAGS) -Fo$(TMPDIR)\ $< - -{$(GENERICDIR)}.c{$(TMPDIR)}.obj: - $(cc32) -DBUILD_tcl $(TCL_CFLAGS) -Fo$(TMPDIR)\ $< - -{$(ROOT)\compat}.c{$(TMPDIR)}.obj: - $(cc32) -DBUILD_tcl $(TCL_CFLAGS) -Fo$(TMPDIR)\ $< - -{$(WINDIR)}.rc{$(TMPDIR)}.res: - $(rc32) -fo $@ -r -i $(GENERICDIR) -i $(WINDIR) -D__WIN32__ \ - $(TCL_DEFINES) $< - -clean: - -@$(RM) $(OUTDIR)\*.exp - -@$(RM) $(OUTDIR)\*.lib - -@$(RM) $(OUTDIR)\*.dll - -@$(RM) $(OUTDIR)\*.exe - -@$(RM) $(OUTDIR)\*.pdb - -@$(RM) $(TMPDIR)\*.pch - -@$(RM) $(TMPDIR)\*.obj - -@$(RM) $(TMPDIR)\*.res - -@$(RM) $(TMPDIR)\*.exe - -@$(RMDIR) $(OUTDIR) - -@$(RMDIR) $(TMPDIR) diff --git a/win/mkd.bat b/win/mkd.bat deleted file mode 100644 index 97f36ae..0000000 --- a/win/mkd.bat +++ /dev/null @@ -1,20 +0,0 @@ -@echo off -rem RCS: @(#) $Id: mkd.bat,v 1.5 1999/12/22 00:00:16 hobbs Exp $ - -if exist %1\. goto end - -if "%OS%" == "Windows_NT" goto winnt - -md %1 -if errorlevel 1 goto end - -goto success - -:winnt -md %1 -if errorlevel 1 goto end - -:success -echo created directory %1 - -:end diff --git a/win/rmd.bat b/win/rmd.bat deleted file mode 100644 index 7b5ce5f..0000000 --- a/win/rmd.bat +++ /dev/null @@ -1,25 +0,0 @@ -@echo off -rem RCS: @(#) $Id: rmd.bat,v 1.5 1999/12/22 00:00:16 hobbs Exp $ - -if not exist %1\. goto end - -echo Removing directory %1 - -if "%OS%" == "Windows_NT" goto winnt - -cd %1 -if errorlevel 1 goto end -del *.* -cd .. -rmdir %1 -if errorlevel 1 goto end -goto success - -:winnt -rmdir %1 /s /q -if errorlevel 1 goto end - -:success -echo deleted directory %1 - -:end diff --git a/win/stub16.c b/win/stub16.c deleted file mode 100644 index 7114d4e..0000000 --- a/win/stub16.c +++ /dev/null @@ -1,198 +0,0 @@ -/* - * stub16.c - * - * A helper program used for running 16-bit DOS applications under - * Windows 95. - * - * Copyright (c) 1996 by Sun Microsystems, Inc. - * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: stub16.c,v 1.4 1999/04/21 21:50:34 rjohnson Exp $ - */ - -#define STRICT - -#include <windows.h> -#include <stdio.h> - -static HANDLE CreateTempFile(void); - -/* - *--------------------------------------------------------------------------- - * - * main - * - * Entry point for the 32-bit console mode app used by Windows 95 to - * help run the 16-bit program specified on the command line. - * - * 1. EOF on a pipe that connects a detached 16-bit process and a - * 32-bit process is never seen. So, this process runs the 16-bit - * process _attached_, and then it is run detached from the calling - * 32-bit process. - * - * 2. If a 16-bit process blocks reading from or writing to a pipe, - * it never wakes up, and eventually brings the whole system down - * with it if you try to kill the process. This app simulates - * pipes. If any of the stdio handles is a pipe, this program - * accumulates information into temp files and forwards it to or - * from the DOS application as appropriate. This means that this - * program must receive EOF from a stdin pipe before it will actually - * start the DOS app, and the DOS app must finish generating stdout - * or stderr before the data will be sent to the next stage of the - * pipe. If the stdio handles are not pipes, no accumulation occurs - * and the data is passed straight through to and from the DOS - * application. - * - * Results: - * None. - * - * Side effects: - * The child process is created and this process waits for it to - * complete. - * - *--------------------------------------------------------------------------- - */ - -int -main() -{ - DWORD dwRead, dwWrite; - char *cmdLine; - HANDLE hStdInput, hStdOutput, hStdError; - HANDLE hFileInput, hFileOutput, hFileError; - STARTUPINFO si; - PROCESS_INFORMATION pi; - char buf[8192]; - DWORD result; - - hFileInput = INVALID_HANDLE_VALUE; - hFileOutput = INVALID_HANDLE_VALUE; - hFileError = INVALID_HANDLE_VALUE; - result = 1; - - /* - * Don't get command line from argc, argv, because the command line - * tokenizer will have stripped off all the escape sequences needed - * for quotes and backslashes, and then we'd have to put them all - * back in again. Get the raw command line and parse off what we - * want ourselves. The command line should be of the form: - * - * stub16.exe program arg1 arg2 ... - */ - - cmdLine = strchr(GetCommandLine(), ' '); - if (cmdLine == NULL) { - return 1; - } - cmdLine++; - - hStdInput = GetStdHandle(STD_INPUT_HANDLE); - hStdOutput = GetStdHandle(STD_OUTPUT_HANDLE); - hStdError = GetStdHandle(STD_ERROR_HANDLE); - - if (GetFileType(hStdInput) == FILE_TYPE_PIPE) { - hFileInput = CreateTempFile(); - if (hFileInput == INVALID_HANDLE_VALUE) { - goto cleanup; - } - while (ReadFile(hStdInput, buf, sizeof(buf), &dwRead, NULL) != FALSE) { - if (dwRead == 0) { - break; - } - if (WriteFile(hFileInput, buf, dwRead, &dwWrite, NULL) == FALSE) { - goto cleanup; - } - } - SetFilePointer(hFileInput, 0, 0, FILE_BEGIN); - SetStdHandle(STD_INPUT_HANDLE, hFileInput); - } - if (GetFileType(hStdOutput) == FILE_TYPE_PIPE) { - hFileOutput = CreateTempFile(); - if (hFileOutput == INVALID_HANDLE_VALUE) { - goto cleanup; - } - SetStdHandle(STD_OUTPUT_HANDLE, hFileOutput); - } - if (GetFileType(hStdError) == FILE_TYPE_PIPE) { - hFileError = CreateTempFile(); - if (hFileError == INVALID_HANDLE_VALUE) { - goto cleanup; - } - SetStdHandle(STD_ERROR_HANDLE, hFileError); - } - - ZeroMemory(&si, sizeof(si)); - si.cb = sizeof(si); - if (CreateProcess(NULL, cmdLine, NULL, NULL, TRUE, 0, NULL, NULL, &si, - &pi) == FALSE) { - goto cleanup; - } - - WaitForInputIdle(pi.hProcess, 5000); - WaitForSingleObject(pi.hProcess, INFINITE); - GetExitCodeProcess(pi.hProcess, &result); - CloseHandle(pi.hProcess); - CloseHandle(pi.hThread); - - if (hFileOutput != INVALID_HANDLE_VALUE) { - SetFilePointer(hFileOutput, 0, 0, FILE_BEGIN); - while (ReadFile(hFileOutput, buf, sizeof(buf), &dwRead, NULL) != FALSE) { - if (dwRead == 0) { - break; - } - if (WriteFile(hStdOutput, buf, dwRead, &dwWrite, NULL) == FALSE) { - break; - } - } - } - if (hFileError != INVALID_HANDLE_VALUE) { - SetFilePointer(hFileError, 0, 0, FILE_BEGIN); - while (ReadFile(hFileError, buf, sizeof(buf), &dwRead, NULL) != FALSE) { - if (dwRead == 0) { - break; - } - if (WriteFile(hStdError, buf, dwRead, &dwWrite, NULL) == FALSE) { - break; - } - } - } - -cleanup: - if (hFileInput != INVALID_HANDLE_VALUE) { - CloseHandle(hFileInput); - } - if (hFileOutput != INVALID_HANDLE_VALUE) { - CloseHandle(hFileOutput); - } - if (hFileError != INVALID_HANDLE_VALUE) { - CloseHandle(hFileError); - } - CloseHandle(hStdInput); - CloseHandle(hStdOutput); - CloseHandle(hStdError); - ExitProcess(result); - return 1; -} - -static HANDLE -CreateTempFile() -{ - char name[MAX_PATH]; - SECURITY_ATTRIBUTES sa; - - if (GetTempPath(sizeof(name), name) == 0) { - return INVALID_HANDLE_VALUE; - } - if (GetTempFileName(name, "tcl", 0, name) == 0) { - return INVALID_HANDLE_VALUE; - } - - sa.nLength = sizeof(sa); - sa.lpSecurityDescriptor = NULL; - sa.bInheritHandle = TRUE; - return CreateFile(name, GENERIC_READ | GENERIC_WRITE, 0, &sa, - CREATE_ALWAYS, FILE_ATTRIBUTE_TEMPORARY | FILE_FLAG_DELETE_ON_CLOSE, - NULL); -} diff --git a/win/tcl.hpj.in b/win/tcl.hpj.in deleted file mode 100644 index c1a805a..0000000 --- a/win/tcl.hpj.in +++ /dev/null @@ -1,19 +0,0 @@ -; This file is maintained by HCW. Do not modify this file directly.
-
-[OPTIONS]
-HCW=0
-LCID=0x409 0x0 0x0 ;English (United States)
-REPORT=Yes
-TITLE=Tcl/Tk Reference Manual
-CNT=tcl83.cnt
-COPYRIGHT=Copyright © 2000 Scriptics Corporation
-HLP=tcl83.hlp
-
-[FILES]
-tcl.rtf
-
-[WINDOWS]
-main="Tcl/Tk Reference Manual",,0
-
-[CONFIG]
-BrowseButtons()
diff --git a/win/tcl.m4 b/win/tcl.m4 deleted file mode 100644 index 86fd936..0000000 --- a/win/tcl.m4 +++ /dev/null @@ -1,625 +0,0 @@ -#------------------------------------------------------------------------ -# SC_PATH_TCLCONFIG -- -# -# Locate the tclConfig.sh file and perform a sanity check on -# the Tcl compile flags -# Currently a no-op for Windows -# -# Arguments: -# PATCH_LEVEL The patch level for Tcl if any. -# -# Results: -# -# Adds the following arguments to configure: -# --with-tcl=... -# -# Sets the following vars: -# TCL_BIN_DIR Full path to the tclConfig.sh file -#------------------------------------------------------------------------ - -AC_DEFUN(SC_PATH_TCLCONFIG, [ - AC_MSG_CHECKING([the location of tclConfig.sh]) - - if test -d ../../tcl8.3$1/win; then - TCL_BIN_DIR_DEFAULT=../../tcl8.3$1/win - else - TCL_BIN_DIR_DEFAULT=../../tcl8.3/win - fi - - AC_ARG_WITH(tcl, [ --with-tcl=DIR use Tcl 8.3 binaries from DIR], - TCL_BIN_DIR=$withval, TCL_BIN_DIR=`cd $TCL_BIN_DIR_DEFAULT; pwd`) - if test ! -d $TCL_BIN_DIR; then - AC_MSG_ERROR(Tcl directory $TCL_BIN_DIR does not exist) - fi - if test ! -f $TCL_BIN_DIR/tclConfig.sh; then - AC_MSG_ERROR(There is no tclConfig.sh in $TCL_BIN_DIR: perhaps you did not specify the Tcl *build* directory (not the toplevel Tcl directory) or you forgot to configure Tcl?) - fi - AC_MSG_RESULT($TCL_BIN_DIR/tclConfig.sh) -]) - -#------------------------------------------------------------------------ -# SC_PATH_TKCONFIG -- -# -# Locate the tkConfig.sh file -# Currently a no-op for Windows -# -# Arguments: -# none -# -# Results: -# -# Adds the following arguments to configure: -# --with-tk=... -# -# Sets the following vars: -# TK_BIN_DIR Full path to the tkConfig.sh file -#------------------------------------------------------------------------ - -AC_DEFUN(SC_PATH_TKCONFIG, [ - AC_MSG_CHECKING([the location of tkConfig.sh]) - - if test -d ../../tk8.3$1/win; then - TK_BIN_DIR_DEFAULT=../../tk8.3$1/win - else - TK_BIN_DIR_DEFAULT=../../tk8.3/win - fi - - AC_ARG_WITH(tk, [ --with-tk=DIR use Tk 8.3 binaries from DIR], - TK_BIN_DIR=$withval, TK_BIN_DIR=`cd $TK_BIN_DIR_DEFAULT; pwd`) - if test ! -d $TK_BIN_DIR; then - AC_MSG_ERROR(Tk directory $TK_BIN_DIR does not exist) - fi - if test ! -f $TK_BIN_DIR/tkConfig.sh; then - AC_MSG_ERROR(There is no tkConfig.sh in $TK_BIN_DIR: perhaps you did not specify the Tk *build* directory (not the toplevel Tk directory) or you forgot to configure Tk?) - fi - - AC_MSG_RESULT([$TK_BIN_DIR/tkConfig.sh]) -]) - -#------------------------------------------------------------------------ -# SC_LOAD_TCLCONFIG -- -# -# Load the tclConfig.sh file -# Currently a no-op for Windows -# -# Arguments: -# -# Requires the following vars to be set: -# TCL_BIN_DIR -# -# Results: -# -# Subst the following vars: -# TCL_BIN_DIR -# TCL_SRC_DIR -# TCL_LIB_FILE -# -#------------------------------------------------------------------------ - -AC_DEFUN(SC_LOAD_TCLCONFIG, [ - AC_MSG_CHECKING([for existence of $TCL_BIN_DIR/tclConfig.sh]) - - if test -f "$TCL_BIN_DIR/tclConfig.sh" ; then - AC_MSG_RESULT([loading]) - . $TCL_BIN_DIR/tclConfig.sh - else - AC_MSG_RESULT([file not found]) - fi - - # The eval is required to do the TCL_DBGX substitution in the - # TCL_LIB_FILE variable. - - eval TCL_LIB_FILE=${TCL_LIB_FILE} - eval TCL_LIB_FLAG=${TCL_LIB_FLAG} - - AC_SUBST(TCL_BIN_DIR) - AC_SUBST(TCL_SRC_DIR) - AC_SUBST(TCL_LIB_FILE) -]) - -#------------------------------------------------------------------------ -# SC_LOAD_TKCONFIG -- -# -# Load the tkConfig.sh file -# Currently a no-op for Windows -# -# Arguments: -# -# Requires the following vars to be set: -# TK_BIN_DIR -# -# Results: -# -# Sets the following vars that should be in tkConfig.sh: -# TK_BIN_DIR -#------------------------------------------------------------------------ - -AC_DEFUN(SC_LOAD_TKCONFIG, [ - AC_MSG_CHECKING([for existence of $TCLCONFIG]) - - if test -f "$TK_BIN_DIR/tkConfig.sh" ; then - AC_MSG_CHECKING([loading $TK_BIN_DIR/tkConfig.sh]) - . $TK_BIN_DIR/tkConfig.sh - else - AC_MSG_RESULT([could not find $TK_BIN_DIR/tkConfig.sh]) - fi - - - AC_SUBST(TK_BIN_DIR) - AC_SUBST(TK_SRC_DIR) - AC_SUBST(TK_LIB_FILE) -]) - -#------------------------------------------------------------------------ -# SC_ENABLE_GCC -- -# -# Allows the use of GCC if available -# -# Arguments: -# none -# -# Results: -# -# Adds the following arguments to configure: -# --enable-gcc -# -# Sets the following vars: -# CC Command to use for the compiler -# AR Comman for the archive tool -# RANLIB Command for the archive indexing tool -# RC Command for the resource compiler -# -#------------------------------------------------------------------------ - -AC_DEFUN(SC_ENABLE_GCC, [ - AC_ARG_ENABLE(gcc, [ --enable-gcc allow use of gcc if available [--disable-gcc]], - [ok=$enableval], [ok=no]) - if test "$ok" = "yes"; then - # Quick hack to simulate a real cross check - # The right way to do this is to use AC_CHECK_TOOL - # correctly, but this is the minimal change - # we need until the real fix is ready. - if test "$host" != "$build" ; then - if test -z "$CC"; then - CC=${host}-gcc - fi - AC_PROG_CC - AC_CHECK_PROG(AR, ${host}-ar, ${host}-ar) - AC_CHECK_PROG(RANLIB, ${host}-ranlib, ${host}-ranlib) - AC_CHECK_PROG(RC, ${host}-windres, ${host}-windres) - else - if test -z "$CC"; then - CC=gcc - fi - AC_PROG_CC - AC_CHECK_PROG(AR, ar, ar) - AC_CHECK_PROG(RANLIB, ranlib, ranlib) - AC_CHECK_PROG(RC, windres, windres) - fi - else - # Allow user to override - if test -z "$CC"; then - CC=cl - fi - fi -]) - -#------------------------------------------------------------------------ -# SC_ENABLE_SHARED -- -# -# Allows the building of shared libraries -# -# Arguments: -# none -# -# Results: -# -# Adds the following arguments to configure: -# --enable-shared=yes|no -# -# Defines the following vars: -# STATIC_BUILD Used for building import/export libraries -# on Windows. -# -# Sets the following vars: -# SHARED_BUILD Value of 1 or 0 -#------------------------------------------------------------------------ - -AC_DEFUN(SC_ENABLE_SHARED, [ - AC_MSG_CHECKING([how to build libraries]) - AC_ARG_ENABLE(shared, - [ --enable-shared build and link with shared libraries [--enable-shared]], - [tcl_ok=$enableval], [tcl_ok=yes]) - - if test "${enable_shared+set}" = set; then - enableval="$enable_shared" - tcl_ok=$enableval - else - tcl_ok=yes - fi - - if test "$tcl_ok" = "yes" ; then - AC_MSG_RESULT([shared]) - SHARED_BUILD=1 - else - AC_MSG_RESULT([static]) - SHARED_BUILD=0 - AC_DEFINE(STATIC_BUILD) - fi -]) - -#------------------------------------------------------------------------ -# SC_ENABLE_THREADS -- -# -# Specify if thread support should be enabled -# -# Arguments: -# none -# -# Results: -# -# Adds the following arguments to configure: -# --enable-threads=yes|no -# -# Defines the following vars: -# TCL_THREADS -#------------------------------------------------------------------------ - -AC_DEFUN(SC_ENABLE_THREADS, [ - AC_MSG_CHECKING(for building with threads) - AC_ARG_ENABLE(threads, [ --enable-threads build with threads], - [tcl_ok=$enableval], [tcl_ok=no]) - - if test "$tcl_ok" = "yes"; then - AC_MSG_RESULT(yes) - TCL_THREADS=1 - AC_DEFINE(TCL_THREADS) - else - TCL_THREADS=0 - AC_MSG_RESULT([no (default)]) - fi -]) - -#------------------------------------------------------------------------ -# SC_ENABLE_SYMBOLS -- -# -# Specify if debugging symbols should be used -# -# Arguments: -# none -# -# Requires the following vars to be set: -# CFLAGS_DEBUG -# CFLAGS_OPTIMIZE -# -# Results: -# -# Adds the following arguments to configure: -# --enable-symbols -# -# Defines the following vars: -# CFLAGS_DEFAULT Sets to CFLAGS_DEBUG if true -# Sets to CFLAGS_OPTIMIZE if false -# LDFLAGS_DEFAULT Sets to LDFLAGS_DEBUG if true -# Sets to LDFLAGS_OPTIMIZE if false -# DBGX Debug library extension -# -#------------------------------------------------------------------------ - -AC_DEFUN(SC_ENABLE_SYMBOLS, [ - AC_MSG_CHECKING([for build with symbols]) - AC_ARG_ENABLE(symbols, [ --enable-symbols build with debugging symbols [--disable-symbols]], [tcl_ok=$enableval], [tcl_ok=no]) - - if test "$tcl_ok" = "yes"; then - CFLAGS_DEFAULT="${CFLAGS_DEBUG}" - LDFLAGS_DEFAULT="${LDFLAGS_DEBUG}" - DBGX=d - AC_MSG_RESULT([yes]) - else - CFLAGS_DEFAULT="${CFLAGS_OPTIMIZE}" - LDFLAGS_DEFAULT="${LDFLAGS_OPTIMIZE}" - DBGX="" - AC_MSG_RESULT([no]) - fi -]) - - -#-------------------------------------------------------------------- -# SC_CONFIG_CFLAGS -# -# Try to determine the proper flags to pass to the compiler -# for building shared libraries and other such nonsense. -# -# NOTE: The backslashes in quotes below are substituted twice -# due to the fact that they are in a macro and then inlined -# in the final configure script. -# -# Arguments: -# none -# -# Results: -# -# Can the following vars: -# EXTRA_CFLAGS -# CFLAGS_DEBUG -# CFLAGS_OPTIMIZE -# CFLAGS_WARNING -# LDFLAGS_DEBUG -# LDFLAGS_OPTIMIZE -# LDFLAGS_CONSOLE -# LDFLAGS_WINDOW -# CC_OBJNAME -# CC_EXENAME -# PATHTYPE -# VPSEP -# CYGPATH -# SHLIB_LD -# SHLIB_LD_LIBS -# LIBS -# AR -# RC -# RES -# -# MAKE_LIB -# MAKE_EXE -# MAKE_DLL -# -# LIBSUFFIX -# LIBPREFIX -# LIBRARIES -# EXESUFFIX -# DLLSUFFIX -# -#-------------------------------------------------------------------- - -AC_DEFUN(SC_CONFIG_CFLAGS, [ - AC_MSG_CHECKING([compiler flags]) - - # Set some defaults (may get changed below) - EXTRA_CFLAGS="" - PATHTYPE='-w' - CYGPATH='cygpath' - VPSEP=';' - - # set various compiler flags depending on whether we are using gcc or cl - - if test "${GCC}" = "yes" ; then - SHLIB_LD="" - SHLIB_LD_LIBS="" - LIBS="" - LIBS_GUI="-lgdi32 -lcomdlg32" - STLIB_LD="${AR}" - RC_OUT=-o - RC_TYPE= - RC_INCLUDE=--include - RES=res.o - MAKE_LIB="\${AR} crv \[$]@" - POST_MAKE_LIB="\${RANLIB} \[$]@" - MAKE_EXE="\${CC} -o \[$]@" - LIBPREFIX="lib" - - if "$CC" -v 2>&1 | egrep '\/gcc-lib\/i[[3-6]]86[[^\/]]*-cygwin' >/dev/null; then - mno_cygwin="yes" - extra_cflags="-mno-cygwin" - extra_ldflags="-mno-cygwin" - else - mno_cygwin="no" - extra_cflags="" - extra_ldflags="" - fi - - if test "$cross_compiling" = "yes" -o "$mno_cygwin" = "yes"; then - PATHTYPE='' - CYGPATH='echo ' - VPSEP=':' - fi - - if test "${SHARED_BUILD}" = "0" ; then - # static - AC_MSG_RESULT([using static flags]) - runtime= - MAKE_DLL="echo " - LIBSUFFIX="s\${DBGX}.a" - LIBRARIES="\${STATIC_LIBRARIES}" - EXESUFFIX="s\${DBGX}.exe" - DLLSUFFIX="" - else - # dynamic - AC_MSG_RESULT([using shared flags]) - - # check to see if ld supports --shared. Libtool does a much - # more extensive test, but not really needed in this case. - if test -z "$LD"; then - ld_prog="`(${CC} -print-prog-name=ld) 2>/dev/null`" - if test -z "$ld_prog"; then - ld_prog=ld - else - # get rid of the potential '\r' from ld_prog. - ld_prog="`(echo $ld_prog | tr -d '\015' | sed 's,\\\\,\\/,g')`" - fi - LD="$ld_prog" - fi - - AC_MSG_CHECKING([whether $ld_prog supports -shared option]) - - # now the ad-hoc check to see if GNU ld supports --shared. - if "$LD" --shared 2>&1 | egrep ': -shared not supported' >/dev/null; then - ld_supports_shared="no" - SHLIB_LD="${DLLWRAP-dllwrap}" - else - ld_supports_shared="yes" - SHLIB_LD="${CC} -shared" - fi - AC_MSG_RESULT([$ld_supports_shared]) - - runtime= - # Add SHLIB_LD_LIBS to the Make rule, not here. - MAKE_DLL="\${SHLIB_LD} \$(LDFLAGS) -o \[$]@ ${extra_ldflags}" - if test "${ld_supports_shared}" = "yes"; then - MAKE_DLL="${MAKE_DLL} -Wl,--out-implib,\$(patsubst %.dll,lib%.a,\[$]@)" - else - MAKE_DLL="${MAKE_DLL} --output-lib \$(patsubst %.dll,lib%.a,\[$]@)" - fi - LIBSUFFIX="\${DBGX}.a" - DLLSUFFIX="\${DBGX}.dll" - EXESUFFIX="\${DBGX}.exe" - LIBRARIES="\${SHARED_LIBRARIES}" - fi - - EXTRA_CFLAGS="${extra_cflags}" - - CFLAGS_DEBUG=-g - CFLAGS_OPTIMIZE=-O - CFLAGS_WARNING="-Wall -Wconversion" - LDFLAGS_DEBUG=-g - LDFLAGS_OPTIMIZE=-O - - # Specify the CC output file names based on the target name - CC_OBJNAME="-o \[$]@" - CC_EXENAME="-o \[$]@" - - # Specify linker flags depending on the type of app being - # built -- Console vs. Window. - LDFLAGS_CONSOLE="-mconsole ${extra_ldflags}" - LDFLAGS_WINDOW="-mwindows ${extra_ldflags}" - else - SHLIB_LD="link -dll -nologo" - SHLIB_LD_LIBS="user32.lib advapi32.lib" - LIBS="user32.lib advapi32.lib" - LIBS_GUI="gdi32.lib comdlg32.lib" - AR="lib -nologo" - STLIB_LD="lib -nologo" - RC="rc" - RC_OUT=-fo - RC_TYPE=-r - RC_INCLUDE=-i - RES=res - MAKE_LIB="\${AR} -out:\[$]@" - POST_MAKE_LIB= - MAKE_EXE="\${CC} -Fe\[$]@" - LIBPREFIX="" - - if test "${SHARED_BUILD}" = "0" ; then - # static - AC_MSG_RESULT([using static flags]) - runtime=-MT - MAKE_DLL="echo " - LIBSUFFIX="s\${DBGX}.lib" - LIBRARIES="\${STATIC_LIBRARIES}" - EXESUFFIX="s\${DBGX}.exe" - DLLSUFFIX="" - else - # dynamic - AC_MSG_RESULT([using shared flags]) - runtime=-MD - # Add SHLIB_LD_LIBS to the Make rule, not here. - MAKE_DLL="\${SHLIB_LD} \$(LDFLAGS) -out:\[$]@" - LIBSUFFIX="\${DBGX}.lib" - DLLSUFFIX="\${DBGX}.dll" - EXESUFFIX="\${DBGX}.exe" - LIBRARIES="\${SHARED_LIBRARIES}" - fi - - EXTRA_CFLAGS="-YX" - CFLAGS_DEBUG="-nologo -Z7 -Od -WX ${runtime}d" -# CFLAGS_OPTIMIZE="-nologo -O2 -Gs -GD ${runtime}" - CFLAGS_OPTIMIZE="-nologo -Oti -Gs -GD ${runtime}" - CFLAGS_WARNING="-W3" - LDFLAGS_DEBUG="-debug:full -debugtype:cv" - LDFLAGS_OPTIMIZE="-release" - - # Specify the CC output file names based on the target name - CC_OBJNAME="-Fo\[$]@" - CC_EXENAME="-Fe\"\$(shell \$(CYGPATH) \$(PATHTYPE) '\[$]@')\"" - - # Specify linker flags depending on the type of app being - # built -- Console vs. Window. - LDFLAGS_CONSOLE="-link -subsystem:console" - LDFLAGS_WINDOW="-link -subsystem:windows" - fi -]) - -#------------------------------------------------------------------------ -# SC_WITH_TCL -- -# -# Location of the Tcl build directory. -# -# Arguments: -# none -# -# Results: -# -# Adds the following arguments to configure: -# --with-tcl=... -# -# Defines the following vars: -# TCL_BIN_DIR Full path to the tcl build dir. -#------------------------------------------------------------------------ - -AC_DEFUN(SC_WITH_TCL, [ - if test -d ../../tcl8.3$1/win; then - TCL_BIN_DEFAULT=../../tcl8.3$1/win - else - TCL_BIN_DEFAULT=../../tcl8.3/win - fi - - AC_ARG_WITH(tcl, [ --with-tcl=DIR use Tcl 8.3 binaries from DIR], - TCL_BIN_DIR=$withval, TCL_BIN_DIR=`cd $TCL_BIN_DEFAULT; pwd`) - if test ! -d $TCL_BIN_DIR; then - AC_MSG_ERROR(Tcl directory $TCL_BIN_DIR does not exist) - fi - if test ! -f $TCL_BIN_DIR/Makefile; then - AC_MSG_ERROR(There is no Makefile in $TCL_BIN_DIR: perhaps you did not specify the Tcl *build* directory (not the toplevel Tcl directory) or you forgot to configure Tcl?) - else - echo "building against Tcl binaries in: $TCL_BIN_DIR" - fi - AC_SUBST(TCL_BIN_DIR) -]) - -# FIXME : SC_PROG_TCLSH should really look for the installed tclsh and -# not the build version. If we want to use the build version in the -# tk script, it is better to hardcode that! - -#------------------------------------------------------------------------ -# SC_PROG_TCLSH -# Locate a tclsh shell in the following directories: -# ${exec_prefix}/bin -# ${prefix}/bin -# ${TCL_BIN_DIR} -# ${TCL_BIN_DIR}/../bin -# ${PATH} -# -# Arguments -# none -# -# Results -# Subst's the following values: -# TCLSH_PROG -#------------------------------------------------------------------------ - -AC_DEFUN(SC_PROG_TCLSH, [ - AC_MSG_CHECKING([for tclsh]) - - AC_CACHE_VAL(ac_cv_path_tclsh, [ - search_path=`echo ${exec_prefix}/bin:${prefix}/bin:${TCL_BIN_DIR}:${TCL_BIN_DIR}/../bin:${PATH} | sed -e 's/:/ /g'` - for dir in $search_path ; do - for j in `ls -r $dir/tclsh[[8-9]]*.exe 2> /dev/null` \ - `ls -r $dir/tclsh* 2> /dev/null` ; do - if test x"$ac_cv_path_tclsh" = x ; then - if test -f "$j" ; then - ac_cv_path_tclsh=$j - break - fi - fi - done - done - ]) - - if test -f "$ac_cv_path_tclsh" ; then - TCLSH_PROG=$ac_cv_path_tclsh - AC_MSG_RESULT($TCLSH_PROG) - else - AC_MSG_ERROR(No tclsh found in PATH: $search_path) - fi - AC_SUBST(TCLSH_PROG) -]) diff --git a/win/tcl.rc b/win/tcl.rc deleted file mode 100644 index 5b9a8cf..0000000 --- a/win/tcl.rc +++ /dev/null @@ -1,46 +0,0 @@ -// RCS: @(#) $Id: tcl.rc,v 1.5 2000/04/18 23:26:45 redman Exp $ -// -// Version -// - -#define VS_VERSION_INFO 1 - -#define RESOURCE_INCLUDED -#include <tcl.h> - -LANGUAGE 0x9, 0x1 /* LANG_ENGLISH, SUBLANG_DEFAULT */ - -VS_VERSION_INFO VERSIONINFO - FILEVERSION TCL_MAJOR_VERSION,TCL_MINOR_VERSION,TCL_RELEASE_LEVEL,TCL_RELEASE_SERIAL - PRODUCTVERSION TCL_MAJOR_VERSION,TCL_MINOR_VERSION,TCL_RELEASE_LEVEL,TCL_RELEASE_SERIAL - FILEFLAGSMASK 0x3fL - FILEFLAGS 0x0L - FILEOS 0x4 /* VOS__WINDOWS32 */ - FILETYPE 0x2 /* VFT_DLL */ - FILESUBTYPE 0x0L -BEGIN - BLOCK "StringFileInfo" - BEGIN - BLOCK "040904b0" /* LANG_ENGLISH/SUBLANG_ENGLISH_US, Unicode CP */ - BEGIN - VALUE "FileDescription", "Tcl DLL\0" - VALUE "OriginalFilename", "tcl" STRINGIFY(TCL_MAJOR_VERSION) STRINGIFY(TCL_MINOR_VERSION) ".dll\0" - VALUE "CompanyName", "Scriptics Corporation\0" - VALUE "FileVersion", TCL_PATCH_LEVEL - VALUE "LegalCopyright", "Copyright (c) 2000 by Scriptics Corporation\0" - VALUE "ProductName", "Tcl " TCL_VERSION " for Windows\0" - VALUE "ProductVersion", TCL_PATCH_LEVEL - END - END - BLOCK "VarFileInfo" - BEGIN - VALUE "Translation", 0x409, 1200 - END -END - - - - - - - diff --git a/win/tclAppInit.c b/win/tclAppInit.c deleted file mode 100644 index b8f3e78..0000000 --- a/win/tclAppInit.c +++ /dev/null @@ -1,301 +0,0 @@ -/* - * tclAppInit.c -- - * - * Provides a default version of the main program and Tcl_AppInit - * procedure for Tcl applications (without Tk). Note that this - * program must be built in Win32 console mode to work properly. - * - * Copyright (c) 1996-1997 by Sun Microsystems, Inc. - * Copyright (c) 1998-1999 by Scriptics Corporation. - * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclAppInit.c,v 1.6 1999/12/02 02:03:37 redman Exp $ - */ - -#include "tcl.h" -#include <windows.h> -#include <locale.h> - -#ifdef TCL_TEST -extern int Procbodytest_Init _ANSI_ARGS_((Tcl_Interp *interp)); -extern int Procbodytest_SafeInit _ANSI_ARGS_((Tcl_Interp *interp)); -extern int Tcltest_Init _ANSI_ARGS_((Tcl_Interp *interp)); -extern int TclObjTest_Init _ANSI_ARGS_((Tcl_Interp *interp)); -#ifdef TCL_THREADS -extern int TclThread_Init _ANSI_ARGS_((Tcl_Interp *interp)); -#endif -#endif /* TCL_TEST */ - -static void setargv _ANSI_ARGS_((int *argcPtr, char ***argvPtr)); - - -/* - *---------------------------------------------------------------------- - * - * main -- - * - * This is the main program for the application. - * - * Results: - * None: Tcl_Main never returns here, so this procedure never - * returns either. - * - * Side effects: - * Whatever the application does. - * - *---------------------------------------------------------------------- - */ - -int -main(argc, argv) - int argc; /* Number of command-line arguments. */ - char **argv; /* Values of command-line arguments. */ -{ - /* - * The following #if block allows you to change the AppInit - * function by using a #define of TCL_LOCAL_APPINIT instead - * of rewriting this entire file. The #if checks for that - * #define and uses Tcl_AppInit if it doesn't exist. - */ - -#ifndef TCL_LOCAL_APPINIT -#define TCL_LOCAL_APPINIT Tcl_AppInit -#endif - extern int TCL_LOCAL_APPINIT _ANSI_ARGS_((Tcl_Interp *interp)); - - /* - * The following #if block allows you to change how Tcl finds the startup - * script, prime the library or encoding paths, fiddle with the argv, - * etc., without needing to rewrite Tcl_Main() - */ - -#ifdef TCL_LOCAL_MAIN_HOOK - extern int TCL_LOCAL_MAIN_HOOK _ANSI_ARGS_((int *argc, char ***argv)); -#endif - - char buffer[MAX_PATH +1]; - char *p; - /* - * Set up the default locale to be standard "C" locale so parsing - * is performed correctly. - */ - - setlocale(LC_ALL, "C"); - setargv(&argc, &argv); - - /* - * Replace argv[0] with full pathname of executable, and forward - * slashes substituted for backslashes. - */ - - GetModuleFileName(NULL, buffer, sizeof(buffer)); - argv[0] = buffer; - for (p = buffer; *p != '\0'; p++) { - if (*p == '\\') { - *p = '/'; - } - } - -#ifdef TCL_LOCAL_MAIN_HOOK - TCL_LOCAL_MAIN_HOOK(&argc, &argv); -#endif - - Tcl_Main(argc, argv, TCL_LOCAL_APPINIT); - - return 0; /* Needed only to prevent compiler warning. */ -} - - -/* - *---------------------------------------------------------------------- - * - * Tcl_AppInit -- - * - * This procedure performs application-specific initialization. - * Most applications, especially those that incorporate additional - * packages, will have their own version of this procedure. - * - * Results: - * Returns a standard Tcl completion code, and leaves an error - * message in the interp's result if an error occurs. - * - * Side effects: - * Depends on the startup script. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_AppInit(interp) - Tcl_Interp *interp; /* Interpreter for application. */ -{ - if (Tcl_Init(interp) == TCL_ERROR) { - return TCL_ERROR; - } - -#ifdef TCL_TEST - if (Tcltest_Init(interp) == TCL_ERROR) { - return TCL_ERROR; - } - Tcl_StaticPackage(interp, "Tcltest", Tcltest_Init, - (Tcl_PackageInitProc *) NULL); - if (TclObjTest_Init(interp) == TCL_ERROR) { - return TCL_ERROR; - } -#ifdef TCL_THREADS - if (TclThread_Init(interp) == TCL_ERROR) { - return TCL_ERROR; - } -#endif - if (Procbodytest_Init(interp) == TCL_ERROR) { - return TCL_ERROR; - } - Tcl_StaticPackage(interp, "procbodytest", Procbodytest_Init, - Procbodytest_SafeInit); -#endif /* TCL_TEST */ - - /* - * Call the init procedures for included packages. Each call should - * look like this: - * - * if (Mod_Init(interp) == TCL_ERROR) { - * return TCL_ERROR; - * } - * - * where "Mod" is the name of the module. - */ - - /* - * Call Tcl_CreateCommand for application-specific commands, if - * they weren't already created by the init procedures called above. - */ - - /* - * Specify a user-specific startup file to invoke if the application - * is run interactively. Typically the startup file is "~/.apprc" - * where "app" is the name of the application. If this line is deleted - * then no user-specific startup file will be run under any conditions. - */ - - Tcl_SetVar(interp, "tcl_rcFileName", "~/tclshrc.tcl", TCL_GLOBAL_ONLY); - return TCL_OK; -} - -/* - *------------------------------------------------------------------------- - * - * setargv -- - * - * Parse the Windows command line string into argc/argv. Done here - * because we don't trust the builtin argument parser in crt0. - * Windows applications are responsible for breaking their command - * line into arguments. - * - * 2N backslashes + quote -> N backslashes + begin quoted string - * 2N + 1 backslashes + quote -> literal - * N backslashes + non-quote -> literal - * quote + quote in a quoted string -> single quote - * quote + quote not in quoted string -> empty string - * quote -> begin quoted string - * - * Results: - * Fills argcPtr with the number of arguments and argvPtr with the - * array of arguments. - * - * Side effects: - * Memory allocated. - * - *-------------------------------------------------------------------------- - */ - -static void -setargv(argcPtr, argvPtr) - int *argcPtr; /* Filled with number of argument strings. */ - char ***argvPtr; /* Filled with argument strings (malloc'd). */ -{ - char *cmdLine, *p, *arg, *argSpace; - char **argv; - int argc, size, inquote, copy, slashes; - - cmdLine = GetCommandLine(); /* INTL: BUG */ - - /* - * Precompute an overly pessimistic guess at the number of arguments - * in the command line by counting non-space spans. - */ - - size = 2; - for (p = cmdLine; *p != '\0'; p++) { - if ((*p == ' ') || (*p == '\t')) { /* INTL: ISO space. */ - size++; - while ((*p == ' ') || (*p == '\t')) { /* INTL: ISO space. */ - p++; - } - if (*p == '\0') { - break; - } - } - } - argSpace = (char *) Tcl_Alloc( - (unsigned) (size * sizeof(char *) + strlen(cmdLine) + 1)); - argv = (char **) argSpace; - argSpace += size * sizeof(char *); - size--; - - p = cmdLine; - for (argc = 0; argc < size; argc++) { - argv[argc] = arg = argSpace; - while ((*p == ' ') || (*p == '\t')) { /* INTL: ISO space. */ - p++; - } - if (*p == '\0') { - break; - } - - inquote = 0; - slashes = 0; - while (1) { - copy = 1; - while (*p == '\\') { - slashes++; - p++; - } - if (*p == '"') { - if ((slashes & 1) == 0) { - copy = 0; - if ((inquote) && (p[1] == '"')) { - p++; - copy = 1; - } else { - inquote = !inquote; - } - } - slashes >>= 1; - } - - while (slashes) { - *arg = '\\'; - arg++; - slashes--; - } - - if ((*p == '\0') - || (!inquote && ((*p == ' ') || (*p == '\t')))) { /* INTL: ISO space. */ - break; - } - if (copy != 0) { - *arg = *p; - arg++; - } - p++; - } - *arg = '\0'; - argSpace = arg + 1; - } - argv[argc] = NULL; - - *argcPtr = argc; - *argvPtr = argv; -} diff --git a/win/tclConfig.sh.in b/win/tclConfig.sh.in deleted file mode 100644 index 2aff114..0000000 --- a/win/tclConfig.sh.in +++ /dev/null @@ -1,174 +0,0 @@ -# tclConfig.sh -- -# -# This shell script (for sh) is generated automatically by Tcl's -# configure script. It will create shell variables for most of -# the configuration options discovered by the configure script. -# This script is intended to be included by the configure scripts -# for Tcl extensions so that they don't have to figure this all -# out for themselves. -# -# The information in this file is specific to a single platform. -# -# RCS: @(#) $Id: tclConfig.sh.in,v 1.3.10.2 2000/07/28 07:58:28 mo Exp $ - -TCL_DLL_FILE="@TCL_DLL_FILE@" - -# Tcl's version number. -TCL_VERSION='@TCL_VERSION@' -TCL_MAJOR_VERSION='@TCL_MAJOR_VERSION@' -TCL_MINOR_VERSION='@TCL_MINOR_VERSION@' -TCL_PATCH_LEVEL='@TCL_PATCH_LEVEL@' - -# C compiler to use for compilation. -TCL_CC='@CC@' - -# -D flags for use with the C compiler. -TCL_DEFS='@DEFS@' - -# If TCL was built with debugging symbols, generated libraries contain -# this string at the end of the library name (before the extension). -TCL_DBGX=@TCL_DBGX@ - -# Default flags used in an optimized and debuggable build, respectively. -TCL_CFLAGS_DEBUG='@CFLAGS_DEBUG@' -TCL_CFLAGS_OPTIMIZE='@CFLAGS_OPTIMIZE@' - -# Default linker flags used in an optimized and debuggable build, respectively. -TCL_LDFLAGS_DEBUG='@LDFLAGS_DEBUG@' -TCL_LDFLAGS_OPTIMIZE='@LDFLAGS_OPTIMIZE@' - -# Flag, 1: we built a shared lib, 0 we didn't -TCL_SHARED_BUILD=@TCL_SHARED_BUILD@ - -# The name of the Tcl library (may be either a .a file or a shared library): -TCL_LIB_FILE='@TCL_LIB_FILE@' - -# Flag to indicate whether shared libraries need export files. -TCL_NEEDS_EXP_FILE=@TCL_NEEDS_EXP_FILE@ - -# String that can be evaluated to generate the part of the export file -# name that comes after the "libxxx" (includes version number, if any, -# extension, and anything else needed). May depend on the variables -# VERSION. On most UNIX systems this is ${VERSION}.exp. -TCL_EXPORT_FILE_SUFFIX='@CFG_TCL_EXPORT_FILE_SUFFIX@' - -# Additional libraries to use when linking Tcl. -TCL_LIBS='@LIBS@' - -# Top-level directory in which Tcl's platform-independent files are -# installed. -TCL_PREFIX='@prefix@' - -# Top-level directory in which Tcl's platform-specific files (e.g. -# executables) are installed. -TCL_EXEC_PREFIX='@exec_prefix@' - -# Flags to pass to cc when compiling the components of a shared library: -TCL_SHLIB_CFLAGS='@SHLIB_CFLAGS@' - -# Flags to pass to cc to get warning messages -TCL_CFLAGS_WARNING='@CFLAGS_WARNING@' - -# Extra flags to pass to cc: -TCL_EXTRA_CFLAGS='@EXTRA_CFLAGS@' - -# Base command to use for combining object files into a shared library: -TCL_SHLIB_LD='@SHLIB_LD@' - -# Base command to use for combining object files into a static library: -TCL_STLIB_LD='@STLIB_LD@' - -# Either '$LIBS' (if dependent libraries should be included when linking -# shared libraries) or an empty string. See Tcl's configure.in for more -# explanation. -TCL_SHLIB_LD_LIBS='@SHLIB_LD_LIBS@' - -# Suffix to use for the name of a shared library. -TCL_SHLIB_SUFFIX='@SHLIB_SUFFIX@' - -# Library file(s) to include in tclsh and other base applications -# in order to provide facilities needed by DLOBJ above. -TCL_DL_LIBS='@DL_LIBS@' - -# Flags to pass to the compiler when linking object files into -# an executable tclsh or tcltest binary. -TCL_LD_FLAGS='@LDFLAGS@' - -# Flags to pass to ld, such as "-R /usr/local/tcl/lib", that tell the -# run-time dynamic linker where to look for shared libraries such as -# libtcl.so. Used when linking applications. Only works if there -# is a variable "LIB_RUNTIME_DIR" defined in the Makefile. -TCL_LD_SEARCH_FLAGS='@TCL_LD_SEARCH_FLAGS@' - -# Additional object files linked with Tcl to provide compatibility -# with standard facilities from ANSI C or POSIX. -TCL_COMPAT_OBJS='@LIBOBJS@' - -# Name of the ranlib program to use. -TCL_RANLIB='@RANLIB@' - -# -l flag to pass to the linker to pick up the Tcl library -TCL_LIB_FLAG='@TCL_LIB_FLAG@' - -# String to pass to linker to pick up the Tcl library from its -# build directory. -TCL_BUILD_LIB_SPEC='@TCL_BUILD_LIB_SPEC@' - -# String to pass to linker to pick up the Tcl library from its -# installed directory. -TCL_LIB_SPEC='@TCL_LIB_SPEC@' - -# Indicates whether a version numbers should be used in -l switches -# ("ok" means it's safe to use switches like -ltcl7.5; "nodots" means -# use switches like -ltcl75). SunOS and FreeBSD require "nodots", for -# example. -TCL_LIB_VERSIONS_OK='@TCL_LIB_VERSIONS_OK@' - -# String that can be evaluated to generate the part of a shared library -# name that comes after the "libxxx" (includes version number, if any, -# extension, and anything else needed). May depend on the variables -# VERSION and SHLIB_SUFFIX. On most UNIX systems this is -# ${VERSION}${SHLIB_SUFFIX}. -TCL_SHARED_LIB_SUFFIX='@CFG_TCL_SHARED_LIB_SUFFIX@' - -# String that can be evaluated to generate the part of an unshared library -# name that comes after the "libxxx" (includes version number, if any, -# extension, and anything else needed). May depend on the variable -# VERSION. On most UNIX systems this is ${VERSION}.a. -TCL_UNSHARED_LIB_SUFFIX='@CFG_TCL_UNSHARED_LIB_SUFFIX@' - -# Location of the top-level source directory from which Tcl was built. -# This is the directory that contains a README file as well as -# subdirectories such as generic, unix, etc. If Tcl was compiled in a -# different place than the directory containing the source files, this -# points to the location of the sources, not the location where Tcl was -# compiled. -TCL_SRC_DIR='@TCL_SRC_DIR@' - -# List of standard directories in which to look for packages during -# "package require" commands. Contains the "prefix" directory plus also -# the "exec_prefix" directory, if it is different. -TCL_PACKAGE_PATH='@TCL_PACKAGE_PATH@' - -# Tcl supports stub. -TCL_SUPPORTS_STUBS=1 - -# The name of the Tcl stub library (.a): -TCL_STUB_LIB_FILE='@TCL_STUB_LIB_FILE@' - -# -l flag to pass to the linker to pick up the Tcl stub library -TCL_STUB_LIB_FLAG='@TCL_STUB_LIB_FLAG@' - -# String to pass to linker to pick up the Tcl stub library from its -# build directory. -TCL_BUILD_STUB_LIB_SPEC='@TCL_BUILD_STUB_LIB_SPEC@' - -# String to pass to linker to pick up the Tcl stub library from its -# installed directory. -TCL_STUB_LIB_SPEC='@TCL_STUB_LIB_SPEC@' - -# Path to the Tcl stub library in the build directory. -TCL_BUILD_STUB_LIB_PATH='@TCL_BUILD_STUB_LIB_PATH@' - -# Path to the Tcl stub library in the install directory. -TCL_STUB_LIB_PATH='@TCL_STUB_LIB_PATH@' diff --git a/win/tclWin32Dll.c b/win/tclWin32Dll.c deleted file mode 100644 index ed4051a..0000000 --- a/win/tclWin32Dll.c +++ /dev/null @@ -1,492 +0,0 @@ -/* - * tclWin32Dll.c -- - * - * This file contains the DLL entry point. - * - * Copyright (c) 1995-1996 Sun Microsystems, Inc. - * Copyright (c) 1998-2000 Scriptics Corporation. - * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclWin32Dll.c,v 1.9 2000/03/31 08:52:30 hobbs Exp $ - */ - -#include "tclWinInt.h" - -/* - * The following data structures are used when loading the thunking - * library for execing child processes under Win32s. - */ - -typedef DWORD (WINAPI UT32PROC)(LPVOID lpBuff, DWORD dwUserDefined, - LPVOID *lpTranslationList); - -typedef BOOL (WINAPI UTREGISTER)(HANDLE hModule, LPCSTR SixteenBitDLL, - LPCSTR InitName, LPCSTR ProcName, UT32PROC **ThirtyTwoBitThunk, - FARPROC UT32Callback, LPVOID Buff); - -typedef VOID (WINAPI UTUNREGISTER)(HANDLE hModule); - -/* - * The following variables keep track of information about this DLL - * on a per-instance basis. Each time this DLL is loaded, it gets its own - * new data segment with its own copy of all static and global information. - */ - -static HINSTANCE hInstance; /* HINSTANCE of this DLL. */ -static int platformId; /* Running under NT, or 95/98? */ - -/* - * The following function tables are used to dispatch to either the - * wide-character or multi-byte versions of the operating system calls, - * depending on whether the Unicode calls are available. - */ - -static TclWinProcs asciiProcs = { - 0, - - (BOOL (WINAPI *)(CONST TCHAR *, LPDCB)) BuildCommDCBA, - (TCHAR *(WINAPI *)(TCHAR *)) CharLowerA, - (BOOL (WINAPI *)(CONST TCHAR *, CONST TCHAR *, BOOL)) CopyFileA, - (BOOL (WINAPI *)(CONST TCHAR *, LPSECURITY_ATTRIBUTES)) CreateDirectoryA, - (HANDLE (WINAPI *)(CONST TCHAR *, DWORD, DWORD, SECURITY_ATTRIBUTES *, - DWORD, DWORD, HANDLE)) CreateFileA, - (BOOL (WINAPI *)(CONST TCHAR *, TCHAR *, LPSECURITY_ATTRIBUTES, - LPSECURITY_ATTRIBUTES, BOOL, DWORD, LPVOID, CONST TCHAR *, - LPSTARTUPINFOA, LPPROCESS_INFORMATION)) CreateProcessA, - (BOOL (WINAPI *)(CONST TCHAR *)) DeleteFileA, - (HANDLE (WINAPI *)(CONST TCHAR *, WIN32_FIND_DATAT *)) FindFirstFileA, - (BOOL (WINAPI *)(HANDLE, WIN32_FIND_DATAT *)) FindNextFileA, - (BOOL (WINAPI *)(WCHAR *, LPDWORD)) GetComputerNameA, - (DWORD (WINAPI *)(DWORD, WCHAR *)) GetCurrentDirectoryA, - (DWORD (WINAPI *)(CONST TCHAR *)) GetFileAttributesA, - (DWORD (WINAPI *)(CONST TCHAR *, DWORD nBufferLength, WCHAR *, - TCHAR **)) GetFullPathNameA, - (DWORD (WINAPI *)(HMODULE, WCHAR *, int)) GetModuleFileNameA, - (DWORD (WINAPI *)(CONST TCHAR *, WCHAR *, DWORD)) GetShortPathNameA, - (UINT (WINAPI *)(CONST TCHAR *, CONST TCHAR *, UINT uUnique, - WCHAR *)) GetTempFileNameA, - (DWORD (WINAPI *)(DWORD, WCHAR *)) GetTempPathA, - (BOOL (WINAPI *)(CONST TCHAR *, WCHAR *, DWORD, LPDWORD, LPDWORD, LPDWORD, - WCHAR *, DWORD)) GetVolumeInformationA, - (HINSTANCE (WINAPI *)(CONST TCHAR *)) LoadLibraryA, - (TCHAR (WINAPI *)(WCHAR *, CONST TCHAR *)) lstrcpyA, - (BOOL (WINAPI *)(CONST TCHAR *, CONST TCHAR *)) MoveFileA, - (BOOL (WINAPI *)(CONST TCHAR *)) RemoveDirectoryA, - (DWORD (WINAPI *)(CONST TCHAR *, CONST TCHAR *, CONST TCHAR *, DWORD, - WCHAR *, TCHAR **)) SearchPathA, - (BOOL (WINAPI *)(CONST TCHAR *)) SetCurrentDirectoryA, - (BOOL (WINAPI *)(CONST TCHAR *, DWORD)) SetFileAttributesA, -}; - -static TclWinProcs unicodeProcs = { - 1, - - (BOOL (WINAPI *)(CONST TCHAR *, LPDCB)) BuildCommDCBW, - (TCHAR *(WINAPI *)(TCHAR *)) CharLowerW, - (BOOL (WINAPI *)(CONST TCHAR *, CONST TCHAR *, BOOL)) CopyFileW, - (BOOL (WINAPI *)(CONST TCHAR *, LPSECURITY_ATTRIBUTES)) CreateDirectoryW, - (HANDLE (WINAPI *)(CONST TCHAR *, DWORD, DWORD, SECURITY_ATTRIBUTES *, - DWORD, DWORD, HANDLE)) CreateFileW, - (BOOL (WINAPI *)(CONST TCHAR *, TCHAR *, LPSECURITY_ATTRIBUTES, - LPSECURITY_ATTRIBUTES, BOOL, DWORD, LPVOID, CONST TCHAR *, - LPSTARTUPINFOA, LPPROCESS_INFORMATION)) CreateProcessW, - (BOOL (WINAPI *)(CONST TCHAR *)) DeleteFileW, - (HANDLE (WINAPI *)(CONST TCHAR *, WIN32_FIND_DATAT *)) FindFirstFileW, - (BOOL (WINAPI *)(HANDLE, WIN32_FIND_DATAT *)) FindNextFileW, - (BOOL (WINAPI *)(WCHAR *, LPDWORD)) GetComputerNameW, - (DWORD (WINAPI *)(DWORD, WCHAR *)) GetCurrentDirectoryW, - (DWORD (WINAPI *)(CONST TCHAR *)) GetFileAttributesW, - (DWORD (WINAPI *)(CONST TCHAR *, DWORD nBufferLength, WCHAR *, - TCHAR **)) GetFullPathNameW, - (DWORD (WINAPI *)(HMODULE, WCHAR *, int)) GetModuleFileNameW, - (DWORD (WINAPI *)(CONST TCHAR *, WCHAR *, DWORD)) GetShortPathNameW, - (UINT (WINAPI *)(CONST TCHAR *, CONST TCHAR *, UINT uUnique, - WCHAR *)) GetTempFileNameW, - (DWORD (WINAPI *)(DWORD, WCHAR *)) GetTempPathW, - (BOOL (WINAPI *)(CONST TCHAR *, WCHAR *, DWORD, LPDWORD, LPDWORD, LPDWORD, - WCHAR *, DWORD)) GetVolumeInformationW, - (HINSTANCE (WINAPI *)(CONST TCHAR *)) LoadLibraryW, - (TCHAR (WINAPI *)(WCHAR *, CONST TCHAR *)) lstrcpyW, - (BOOL (WINAPI *)(CONST TCHAR *, CONST TCHAR *)) MoveFileW, - (BOOL (WINAPI *)(CONST TCHAR *)) RemoveDirectoryW, - (DWORD (WINAPI *)(CONST TCHAR *, CONST TCHAR *, CONST TCHAR *, DWORD, - WCHAR *, TCHAR **)) SearchPathW, - (BOOL (WINAPI *)(CONST TCHAR *)) SetCurrentDirectoryW, - (BOOL (WINAPI *)(CONST TCHAR *, DWORD)) SetFileAttributesW, -}; - -TclWinProcs *tclWinProcs; -static Tcl_Encoding tclWinTCharEncoding; - -/* - * The following declaration is for the VC++ DLL entry point. - */ - -BOOL APIENTRY DllMain(HINSTANCE hInst, DWORD reason, - LPVOID reserved); - - -#ifdef __WIN32__ -#ifndef STATIC_BUILD - - -/* - *---------------------------------------------------------------------- - * - * DllEntryPoint -- - * - * This wrapper function is used by Borland to invoke the - * initialization code for Tcl. It simply calls the DllMain - * routine. - * - * Results: - * See DllMain. - * - * Side effects: - * See DllMain. - * - *---------------------------------------------------------------------- - */ - -BOOL APIENTRY -DllEntryPoint(hInst, reason, reserved) - HINSTANCE hInst; /* Library instance handle. */ - DWORD reason; /* Reason this function is being called. */ - LPVOID reserved; /* Not used. */ -{ - return DllMain(hInst, reason, reserved); -} - -/* - *---------------------------------------------------------------------- - * - * DllMain -- - * - * This routine is called by the VC++ C run time library init - * code, or the DllEntryPoint routine. It is responsible for - * initializing various dynamically loaded libraries. - * - * Results: - * TRUE on sucess, FALSE on failure. - * - * Side effects: - * Establishes 32-to-16 bit thunk and initializes sockets library. - * - *---------------------------------------------------------------------- - */ -BOOL APIENTRY -DllMain(hInst, reason, reserved) - HINSTANCE hInst; /* Library instance handle. */ - DWORD reason; /* Reason this function is being called. */ - LPVOID reserved; /* Not used. */ -{ - switch (reason) { - case DLL_PROCESS_ATTACH: - TclWinInit(hInst); - return TRUE; - - case DLL_PROCESS_DETACH: - if (hInst == hInstance) { - Tcl_Finalize(); - } - break; - } - - return TRUE; -} - -#endif /* !STATIC_BUILD */ -#endif /* __WIN32__ */ - -/* - *---------------------------------------------------------------------- - * - * TclWinGetTclInstance -- - * - * Retrieves the global library instance handle. - * - * Results: - * Returns the global library instance handle. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -HINSTANCE -TclWinGetTclInstance() -{ - return hInstance; -} - -/* - *---------------------------------------------------------------------- - * - * TclWinInit -- - * - * This function initializes the internal state of the tcl library. - * - * Results: - * None. - * - * Side effects: - * Initializes the tclPlatformId variable. - * - *---------------------------------------------------------------------- - */ - -void -TclWinInit(hInst) - HINSTANCE hInst; /* Library instance handle. */ -{ - OSVERSIONINFO os; - - hInstance = hInst; - os.dwOSVersionInfoSize = sizeof(OSVERSIONINFO); - GetVersionEx(&os); - platformId = os.dwPlatformId; - - /* - * We no longer support Win32s, so just in case someone manages to - * get a runtime there, make sure they know that. - */ - - if (platformId == VER_PLATFORM_WIN32s) { - panic("Win32s is not a supported platform"); - } - - tclWinProcs = &asciiProcs; -} - -/* - *---------------------------------------------------------------------- - * - * TclWinGetPlatformId -- - * - * Determines whether running under NT, 95, or Win32s, to allow - * runtime conditional code. - * - * Results: - * The return value is one of: - * VER_PLATFORM_WIN32s Win32s on Windows 3.1. (not supported) - * VER_PLATFORM_WIN32_WINDOWS Win32 on Windows 95. - * VER_PLATFORM_WIN32_NT Win32 on Windows NT - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -TclWinGetPlatformId() -{ - return platformId; -} - -/* - *------------------------------------------------------------------------- - * - * TclWinNoBackslash -- - * - * We're always iterating through a string in Windows, changing the - * backslashes to slashes for use in Tcl. - * - * Results: - * All backslashes in given string are changed to slashes. - * - * Side effects: - * None. - * - *------------------------------------------------------------------------- - */ - -char * -TclWinNoBackslash( - char *path) /* String to change. */ -{ - char *p; - - for (p = path; *p != '\0'; p++) { - if (*p == '\\') { - *p = '/'; - } - } - return path; -} - -/* - *---------------------------------------------------------------------- - * - * TclpCheckStackSpace -- - * - * Detect if we are about to blow the stack. Called before an - * evaluation can happen when nesting depth is checked. - * - * Results: - * 1 if there is enough stack space to continue; 0 if not. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -TclpCheckStackSpace() -{ - /* - * We can recurse only if there is at least TCL_WIN_STACK_THRESHOLD - * bytes of stack space left. alloca() is cheap on windows; basically - * it just subtracts from the stack pointer causing the OS to throw an - * exception if the stack pointer is set below the bottom of the stack. - */ - - __try { - alloca(TCL_WIN_STACK_THRESHOLD); - return 1; - } __except (1) {} - - return 0; -} - - -/* - *---------------------------------------------------------------------- - * - * TclWinGetPlatform -- - * - * This is a kludge that allows the test library to get access - * the internal tclPlatform variable. - * - * Results: - * Returns a pointer to the tclPlatform variable. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -TclPlatformType * -TclWinGetPlatform() -{ - return &tclPlatform; -} - -/* - *--------------------------------------------------------------------------- - * - * TclWinSetInterfaces -- - * - * A helper proc that allows the test library to change the - * tclWinProcs structure to dispatch to either the wide-character - * or multi-byte versions of the operating system calls, depending - * on whether Unicode is the system encoding. - * - * Results: - * None. - * - * Side effects: - * None. - * - *--------------------------------------------------------------------------- - */ - -void -TclWinSetInterfaces( - int wide) /* Non-zero to use wide interfaces, 0 - * otherwise. */ -{ - Tcl_FreeEncoding(tclWinTCharEncoding); - - if (wide) { - tclWinProcs = &unicodeProcs; - tclWinTCharEncoding = Tcl_GetEncoding(NULL, "unicode"); - } else { - tclWinProcs = &asciiProcs; - tclWinTCharEncoding = NULL; - } -} - -/* - *--------------------------------------------------------------------------- - * - * Tcl_WinUtfToTChar, Tcl_WinTCharToUtf -- - * - * Convert between UTF-8 and Unicode when running Windows NT or - * the current ANSI code page when running Windows 95. - * - * On Mac, Unix, and Windows 95, all strings exchanged between Tcl - * and the OS are "char" oriented. We need only one Tcl_Encoding to - * convert between UTF-8 and the system's native encoding. We use - * NULL to represent that encoding. - * - * On NT, some strings exchanged between Tcl and the OS are "char" - * oriented, while others are in Unicode. We need two Tcl_Encoding - * APIs depending on whether we are targeting a "char" or Unicode - * interface. - * - * Calling Tcl_UtfToExternal() or Tcl_ExternalToUtf() with an - * encoding of NULL should always used to convert between UTF-8 - * and the system's "char" oriented encoding. The following two - * functions are used in Windows-specific code to convert between - * UTF-8 and Unicode strings (NT) or "char" strings(95). This saves - * you the trouble of writing the following type of fragment over and - * over: - * - * if (running NT) { - * encoding <- Tcl_GetEncoding("unicode"); - * nativeBuffer <- UtfToExternal(encoding, utfBuffer); - * Tcl_FreeEncoding(encoding); - * } else { - * nativeBuffer <- UtfToExternal(NULL, utfBuffer); - * } - * - * By convention, in Windows a TCHAR is a character in the ANSI code - * page on Windows 95, a Unicode character on Windows NT. If you - * plan on targeting a Unicode interfaces when running on NT and a - * "char" oriented interface while running on 95, these functions - * should be used. If you plan on targetting the same "char" - * oriented function on both 95 and NT, use Tcl_UtfToExternal() - * with an encoding of NULL. - * - * Results: - * The result is a pointer to the string in the desired target - * encoding. Storage for the result string is allocated in - * dsPtr; the caller must call Tcl_DStringFree() when the result - * is no longer needed. - * - * Side effects: - * None. - * - *--------------------------------------------------------------------------- - */ - -TCHAR * -Tcl_WinUtfToTChar(string, len, dsPtr) - CONST char *string; /* Source string in UTF-8. */ - int len; /* Source string length in bytes, or < 0 for - * strlen(). */ - Tcl_DString *dsPtr; /* Uninitialized or free DString in which - * the converted string is stored. */ -{ - return (TCHAR *) Tcl_UtfToExternalDString(tclWinTCharEncoding, - string, len, dsPtr); -} - -char * -Tcl_WinTCharToUtf(string, len, dsPtr) - CONST TCHAR *string; /* Source string in Unicode when running - * NT, ANSI when running 95. */ - int len; /* Source string length in bytes, or < 0 for - * platform-specific string length. */ - Tcl_DString *dsPtr; /* Uninitialized or free DString in which - * the converted string is stored. */ -{ - return Tcl_ExternalToUtfDString(tclWinTCharEncoding, - (CONST char *) string, len, dsPtr); -} diff --git a/win/tclWinChan.c b/win/tclWinChan.c deleted file mode 100644 index d6fa836..0000000 --- a/win/tclWinChan.c +++ /dev/null @@ -1,1100 +0,0 @@ -/* - * tclWinChan.c - * - * Channel drivers for Windows channels based on files, command - * pipes and TCP sockets. - * - * Copyright (c) 1995-1997 Sun Microsystems, Inc. - * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclWinChan.c,v 1.10.2.1 2000/07/27 01:39:24 hobbs Exp $ - */ - -#include "tclWinInt.h" - -/* - * State flags used in the info structures below. - */ - -#define FILE_PENDING (1<<0) /* Message is pending in the queue. */ -#define FILE_ASYNC (1<<1) /* Channel is non-blocking. */ -#define FILE_APPEND (1<<2) /* File is in append mode. */ - -#define FILE_TYPE_SERIAL (FILE_TYPE_PIPE+1) -#define FILE_TYPE_CONSOLE (FILE_TYPE_PIPE+2) - -/* - * The following structure contains per-instance data for a file based channel. - */ - -typedef struct FileInfo { - Tcl_Channel channel; /* Pointer to channel structure. */ - int validMask; /* OR'ed combination of TCL_READABLE, - * TCL_WRITABLE, or TCL_EXCEPTION: indicates - * which operations are valid on the file. */ - int watchMask; /* OR'ed combination of TCL_READABLE, - * TCL_WRITABLE, or TCL_EXCEPTION: indicates - * which events should be reported. */ - int flags; /* State flags, see above for a list. */ - HANDLE handle; /* Input/output file. */ - struct FileInfo *nextPtr; /* Pointer to next registered file. */ -} FileInfo; - -typedef struct ThreadSpecificData { - /* - * List of all file channels currently open. - */ - - FileInfo *firstFilePtr; -} ThreadSpecificData; - -static Tcl_ThreadDataKey dataKey; - -/* - * The following structure is what is added to the Tcl event queue when - * file events are generated. - */ - -typedef struct FileEvent { - Tcl_Event header; /* Information that is standard for - * all events. */ - FileInfo *infoPtr; /* Pointer to file info structure. Note - * that we still have to verify that the - * file exists before dereferencing this - * pointer. */ -} FileEvent; - -/* - * Static routines for this file: - */ - -static int FileBlockProc _ANSI_ARGS_((ClientData instanceData, - int mode)); -static void FileChannelExitHandler _ANSI_ARGS_(( - ClientData clientData)); -static void FileCheckProc _ANSI_ARGS_((ClientData clientData, - int flags)); -static int FileCloseProc _ANSI_ARGS_((ClientData instanceData, - Tcl_Interp *interp)); -static int FileEventProc _ANSI_ARGS_((Tcl_Event *evPtr, - int flags)); -static int FileGetHandleProc _ANSI_ARGS_((ClientData instanceData, - int direction, ClientData *handlePtr)); -static ThreadSpecificData *FileInit _ANSI_ARGS_((void)); -static int FileInputProc _ANSI_ARGS_((ClientData instanceData, - char *buf, int toRead, int *errorCode)); -static int FileOutputProc _ANSI_ARGS_((ClientData instanceData, - char *buf, int toWrite, int *errorCode)); -static int FileSeekProc _ANSI_ARGS_((ClientData instanceData, - long offset, int mode, int *errorCode)); -static void FileSetupProc _ANSI_ARGS_((ClientData clientData, - int flags)); -static void FileWatchProc _ANSI_ARGS_((ClientData instanceData, - int mask)); - - -/* - * This structure describes the channel type structure for file based IO. - */ - -static Tcl_ChannelType fileChannelType = { - "file", /* Type name. */ - TCL_CHANNEL_VERSION_2, /* v2 channel */ - FileCloseProc, /* Close proc. */ - FileInputProc, /* Input proc. */ - FileOutputProc, /* Output proc. */ - FileSeekProc, /* Seek proc. */ - NULL, /* Set option proc. */ - NULL, /* Get option proc. */ - FileWatchProc, /* Set up the notifier to watch the channel. */ - FileGetHandleProc, /* Get an OS handle from channel. */ - NULL, /* close2proc. */ - FileBlockProc, /* Set blocking or non-blocking mode.*/ - NULL, /* flush proc. */ - NULL, /* handler proc. */ -}; - - -/* - *---------------------------------------------------------------------- - * - * FileInit -- - * - * This function creates the window used to simulate file events. - * - * Results: - * None. - * - * Side effects: - * Creates a new window and creates an exit handler. - * - *---------------------------------------------------------------------- - */ - -static ThreadSpecificData * -FileInit() -{ - ThreadSpecificData *tsdPtr = - (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey); - if (tsdPtr == NULL) { - tsdPtr = TCL_TSD_INIT(&dataKey); - tsdPtr->firstFilePtr = NULL; - Tcl_CreateEventSource(FileSetupProc, FileCheckProc, NULL); - Tcl_CreateThreadExitHandler(FileChannelExitHandler, NULL); - } - return tsdPtr; -} - -/* - *---------------------------------------------------------------------- - * - * FileChannelExitHandler -- - * - * This function is called to cleanup the channel driver before - * Tcl is unloaded. - * - * Results: - * None. - * - * Side effects: - * Destroys the communication window. - * - *---------------------------------------------------------------------- - */ - -static void -FileChannelExitHandler(clientData) - ClientData clientData; /* Old window proc */ -{ - Tcl_DeleteEventSource(FileSetupProc, FileCheckProc, NULL); -} - -/* - *---------------------------------------------------------------------- - * - * FileSetupProc -- - * - * This procedure is invoked before Tcl_DoOneEvent blocks waiting - * for an event. - * - * Results: - * None. - * - * Side effects: - * Adjusts the block time if needed. - * - *---------------------------------------------------------------------- - */ - -void -FileSetupProc(data, flags) - ClientData data; /* Not used. */ - int flags; /* Event flags as passed to Tcl_DoOneEvent. */ -{ - FileInfo *infoPtr; - Tcl_Time blockTime = { 0, 0 }; - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - - if (!(flags & TCL_FILE_EVENTS)) { - return; - } - - /* - * Check to see if there is a ready file. If so, poll. - */ - - for (infoPtr = tsdPtr->firstFilePtr; infoPtr != NULL; - infoPtr = infoPtr->nextPtr) { - if (infoPtr->watchMask) { - Tcl_SetMaxBlockTime(&blockTime); - break; - } - } -} - -/* - *---------------------------------------------------------------------- - * - * FileCheckProc -- - * - * This procedure is called by Tcl_DoOneEvent to check the file - * event source for events. - * - * Results: - * None. - * - * Side effects: - * May queue an event. - * - *---------------------------------------------------------------------- - */ - -static void -FileCheckProc(data, flags) - ClientData data; /* Not used. */ - int flags; /* Event flags as passed to Tcl_DoOneEvent. */ -{ - FileEvent *evPtr; - FileInfo *infoPtr; - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - - if (!(flags & TCL_FILE_EVENTS)) { - return; - } - - /* - * Queue events for any ready files that don't already have events - * queued (caused by persistent states that won't generate WinSock - * events). - */ - - for (infoPtr = tsdPtr->firstFilePtr; infoPtr != NULL; - infoPtr = infoPtr->nextPtr) { - if (infoPtr->watchMask && !(infoPtr->flags & FILE_PENDING)) { - infoPtr->flags |= FILE_PENDING; - evPtr = (FileEvent *) ckalloc(sizeof(FileEvent)); - evPtr->header.proc = FileEventProc; - evPtr->infoPtr = infoPtr; - Tcl_QueueEvent((Tcl_Event *) evPtr, TCL_QUEUE_TAIL); - } - } -} - -/*---------------------------------------------------------------------- - * - * FileEventProc -- - * - * This function is invoked by Tcl_ServiceEvent when a file event - * reaches the front of the event queue. This procedure invokes - * Tcl_NotifyChannel on the file. - * - * Results: - * Returns 1 if the event was handled, meaning it should be removed - * from the queue. Returns 0 if the event was not handled, meaning - * it should stay on the queue. The only time the event isn't - * handled is if the TCL_FILE_EVENTS flag bit isn't set. - * - * Side effects: - * Whatever the notifier callback does. - * - *---------------------------------------------------------------------- - */ - -static int -FileEventProc(evPtr, flags) - Tcl_Event *evPtr; /* Event to service. */ - int flags; /* Flags that indicate what events to - * handle, such as TCL_FILE_EVENTS. */ -{ - FileEvent *fileEvPtr = (FileEvent *)evPtr; - FileInfo *infoPtr; - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - - if (!(flags & TCL_FILE_EVENTS)) { - return 0; - } - - /* - * Search through the list of watched files for the one whose handle - * matches the event. We do this rather than simply dereferencing - * the handle in the event so that files can be deleted while the - * event is in the queue. - */ - - for (infoPtr = tsdPtr->firstFilePtr; infoPtr != NULL; - infoPtr = infoPtr->nextPtr) { - if (fileEvPtr->infoPtr == infoPtr) { - infoPtr->flags &= ~(FILE_PENDING); - Tcl_NotifyChannel(infoPtr->channel, infoPtr->watchMask); - break; - } - } - return 1; -} - -/* - *---------------------------------------------------------------------- - * - * FileBlockProc -- - * - * Set blocking or non-blocking mode on channel. - * - * Results: - * 0 if successful, errno when failed. - * - * Side effects: - * Sets the device into blocking or non-blocking mode. - * - *---------------------------------------------------------------------- - */ - -static int -FileBlockProc(instanceData, mode) - ClientData instanceData; /* Instance data for channel. */ - int mode; /* TCL_MODE_BLOCKING or - * TCL_MODE_NONBLOCKING. */ -{ - FileInfo *infoPtr = (FileInfo *) instanceData; - - /* - * Files on Windows can not be switched between blocking and nonblocking, - * hence we have to emulate the behavior. This is done in the input - * function by checking against a bit in the state. We set or unset the - * bit here to cause the input function to emulate the correct behavior. - */ - - if (mode == TCL_MODE_NONBLOCKING) { - infoPtr->flags |= FILE_ASYNC; - } else { - infoPtr->flags &= ~(FILE_ASYNC); - } - return 0; -} - -/* - *---------------------------------------------------------------------- - * - * FileCloseProc -- - * - * Closes the IO channel. - * - * Results: - * 0 if successful, the value of errno if failed. - * - * Side effects: - * Closes the physical channel - * - *---------------------------------------------------------------------- - */ - -static int -FileCloseProc(instanceData, interp) - ClientData instanceData; /* Pointer to FileInfo structure. */ - Tcl_Interp *interp; /* Not used. */ -{ - FileInfo *fileInfoPtr = (FileInfo *) instanceData; - FileInfo **nextPtrPtr; - int errorCode = 0; - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - - /* - * Remove the file from the watch list. - */ - - FileWatchProc(instanceData, 0); - - /* - * Don't close the Win32 handle if the handle is a standard channel - * during the exit process. Otherwise, one thread may kill the stdio - * of another. - */ - - if (!TclInExit() - || ((GetStdHandle(STD_INPUT_HANDLE) != fileInfoPtr->handle) - && (GetStdHandle(STD_OUTPUT_HANDLE) != fileInfoPtr->handle) - && (GetStdHandle(STD_ERROR_HANDLE) != fileInfoPtr->handle))) { - if (CloseHandle(fileInfoPtr->handle) == FALSE) { - TclWinConvertError(GetLastError()); - errorCode = errno; - } - } - for (nextPtrPtr = &(tsdPtr->firstFilePtr); (*nextPtrPtr) != NULL; - nextPtrPtr = &((*nextPtrPtr)->nextPtr)) { - if ((*nextPtrPtr) == fileInfoPtr) { - (*nextPtrPtr) = fileInfoPtr->nextPtr; - break; - } - } - ckfree((char *)fileInfoPtr); - return errorCode; -} - -/* - *---------------------------------------------------------------------- - * - * FileSeekProc -- - * - * Seeks on a file-based channel. Returns the new position. - * - * Results: - * -1 if failed, the new position if successful. If failed, it - * also sets *errorCodePtr to the error code. - * - * Side effects: - * Moves the location at which the channel will be accessed in - * future operations. - * - *---------------------------------------------------------------------- - */ - -static int -FileSeekProc(instanceData, offset, mode, errorCodePtr) - ClientData instanceData; /* File state. */ - long offset; /* Offset to seek to. */ - int mode; /* Relative to where - * should we seek? */ - int *errorCodePtr; /* To store error code. */ -{ - FileInfo *infoPtr = (FileInfo *) instanceData; - DWORD moveMethod; - DWORD newPos; - - *errorCodePtr = 0; - if (mode == SEEK_SET) { - moveMethod = FILE_BEGIN; - } else if (mode == SEEK_CUR) { - moveMethod = FILE_CURRENT; - } else { - moveMethod = FILE_END; - } - - newPos = SetFilePointer(infoPtr->handle, offset, NULL, moveMethod); - if (newPos == 0xFFFFFFFF) { - TclWinConvertError(GetLastError()); - *errorCodePtr = errno; - return -1; - } - return newPos; -} - -/* - *---------------------------------------------------------------------- - * - * FileInputProc -- - * - * Reads input from the IO channel into the buffer given. Returns - * count of how many bytes were actually read, and an error indication. - * - * Results: - * A count of how many bytes were read is returned and an error - * indication is returned in an output argument. - * - * Side effects: - * Reads input from the actual channel. - * - *---------------------------------------------------------------------- - */ - -static int -FileInputProc(instanceData, buf, bufSize, errorCode) - ClientData instanceData; /* File state. */ - char *buf; /* Where to store data read. */ - int bufSize; /* How much space is available - * in the buffer? */ - int *errorCode; /* Where to store error code. */ -{ - FileInfo *infoPtr; - DWORD bytesRead; - - *errorCode = 0; - infoPtr = (FileInfo *) instanceData; - - /* - * Note that we will block on reads from a console buffer until a - * full line has been entered. The only way I know of to get - * around this is to write a console driver. We should probably - * do this at some point, but for now, we just block. The same - * problem exists for files being read over the network. - */ - - if (ReadFile(infoPtr->handle, (LPVOID) buf, (DWORD) bufSize, &bytesRead, - (LPOVERLAPPED) NULL) != FALSE) { - return bytesRead; - } - - TclWinConvertError(GetLastError()); - *errorCode = errno; - if (errno == EPIPE) { - return 0; - } - return -1; -} - -/* - *---------------------------------------------------------------------- - * - * FileOutputProc -- - * - * Writes the given output on the IO channel. Returns count of how - * many characters were actually written, and an error indication. - * - * Results: - * A count of how many characters were written is returned and an - * error indication is returned in an output argument. - * - * Side effects: - * Writes output on the actual channel. - * - *---------------------------------------------------------------------- - */ - -static int -FileOutputProc(instanceData, buf, toWrite, errorCode) - ClientData instanceData; /* File state. */ - char *buf; /* The data buffer. */ - int toWrite; /* How many bytes to write? */ - int *errorCode; /* Where to store error code. */ -{ - FileInfo *infoPtr = (FileInfo *) instanceData; - DWORD bytesWritten; - - *errorCode = 0; - - /* - * If we are writing to a file that was opened with O_APPEND, we need to - * seek to the end of the file before writing the current buffer. - */ - - if (infoPtr->flags & FILE_APPEND) { - SetFilePointer(infoPtr->handle, 0, NULL, FILE_END); - } - - if (WriteFile(infoPtr->handle, (LPVOID) buf, (DWORD) toWrite, &bytesWritten, - (LPOVERLAPPED) NULL) == FALSE) { - TclWinConvertError(GetLastError()); - *errorCode = errno; - return -1; - } - FlushFileBuffers(infoPtr->handle); - return bytesWritten; -} - -/* - *---------------------------------------------------------------------- - * - * FileWatchProc -- - * - * Called by the notifier to set up to watch for events on this - * channel. - * - * Results: - * None. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static void -FileWatchProc(instanceData, mask) - ClientData instanceData; /* File state. */ - int mask; /* What events to watch for; OR-ed - * combination of TCL_READABLE, - * TCL_WRITABLE and TCL_EXCEPTION. */ -{ - FileInfo *infoPtr = (FileInfo *) instanceData; - Tcl_Time blockTime = { 0, 0 }; - - /* - * Since the file is always ready for events, we set the block time - * to zero so we will poll. - */ - - infoPtr->watchMask = mask & infoPtr->validMask; - if (infoPtr->watchMask) { - Tcl_SetMaxBlockTime(&blockTime); - } -} - -/* - *---------------------------------------------------------------------- - * - * FileGetHandleProc -- - * - * Called from Tcl_GetChannelHandle to retrieve OS handles from - * a file based channel. - * - * Results: - * Returns TCL_OK with the fd in handlePtr, or TCL_ERROR if - * there is no handle for the specified direction. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -FileGetHandleProc(instanceData, direction, handlePtr) - ClientData instanceData; /* The file state. */ - int direction; /* TCL_READABLE or TCL_WRITABLE */ - ClientData *handlePtr; /* Where to store the handle. */ -{ - FileInfo *infoPtr = (FileInfo *) instanceData; - - if (direction & infoPtr->validMask) { - *handlePtr = (ClientData) infoPtr->handle; - return TCL_OK; - } else { - return TCL_ERROR; - } -} - - -/* - *---------------------------------------------------------------------- - * - * TclpOpenFileChannel -- - * - * Open an File based channel on Unix systems. - * - * Results: - * The new channel or NULL. If NULL, the output argument - * errorCodePtr is set to a POSIX error. - * - * Side effects: - * May open the channel and may cause creation of a file on the - * file system. - * - *---------------------------------------------------------------------- - */ - -Tcl_Channel -TclpOpenFileChannel(interp, fileName, modeString, permissions) - Tcl_Interp *interp; /* Interpreter for error reporting; - * can be NULL. */ - char *fileName; /* Name of file to open. */ - char *modeString; /* A list of POSIX open modes or - * a string such as "rw". */ - int permissions; /* If the open involves creating a - * file, with what modes to create - * it? */ -{ - Tcl_Channel channel = 0; - int seekFlag, mode, channelPermissions; - DWORD accessMode, createMode, shareMode, flags, consoleParams, type; - TCHAR *nativeName; - Tcl_DString ds, buffer; - DCB dcb; - HANDLE handle; - char channelName[16 + TCL_INTEGER_SPACE]; - TclFile readFile = NULL; - TclFile writeFile = NULL; - - mode = TclGetOpenMode(interp, modeString, &seekFlag); - if (mode == -1) { - return NULL; - } - - if (Tcl_TranslateFileName(interp, fileName, &ds) == NULL) { - return NULL; - } - nativeName = Tcl_WinUtfToTChar(Tcl_DStringValue(&ds), - Tcl_DStringLength(&ds), &buffer); - - switch (mode & (O_RDONLY | O_WRONLY | O_RDWR)) { - case O_RDONLY: - accessMode = GENERIC_READ; - channelPermissions = TCL_READABLE; - break; - case O_WRONLY: - accessMode = GENERIC_WRITE; - channelPermissions = TCL_WRITABLE; - break; - case O_RDWR: - accessMode = (GENERIC_READ | GENERIC_WRITE); - channelPermissions = (TCL_READABLE | TCL_WRITABLE); - break; - default: - panic("TclpOpenFileChannel: invalid mode value"); - break; - } - - /* - * Map the creation flags to the NT create mode. - */ - - switch (mode & (O_CREAT | O_EXCL | O_TRUNC)) { - case (O_CREAT | O_EXCL): - case (O_CREAT | O_EXCL | O_TRUNC): - createMode = CREATE_NEW; - break; - case (O_CREAT | O_TRUNC): - createMode = CREATE_ALWAYS; - break; - case O_CREAT: - createMode = OPEN_ALWAYS; - break; - case O_TRUNC: - case (O_TRUNC | O_EXCL): - createMode = TRUNCATE_EXISTING; - break; - default: - createMode = OPEN_EXISTING; - break; - } - - /* - * If the file is being created, get the file attributes from the - * permissions argument, else use the existing file attributes. - */ - - if (mode & O_CREAT) { - if (permissions & S_IWRITE) { - flags = FILE_ATTRIBUTE_NORMAL; - } else { - flags = FILE_ATTRIBUTE_READONLY; - } - } else { - flags = (*tclWinProcs->getFileAttributesProc)(nativeName); - if (flags == 0xFFFFFFFF) { - flags = 0; - } - } - - /* - * Set up the file sharing mode. We want to allow simultaneous access. - */ - - shareMode = FILE_SHARE_READ | FILE_SHARE_WRITE; - - /* - * Now we get to create the file. - */ - - handle = (*tclWinProcs->createFileProc)(nativeName, accessMode, - shareMode, NULL, createMode, flags, (HANDLE) NULL); - - if (handle == INVALID_HANDLE_VALUE) { - DWORD err; - err = GetLastError(); - if ((err & 0xffffL) == ERROR_OPEN_FAILED) { - err = (mode & O_CREAT) ? ERROR_FILE_EXISTS : ERROR_FILE_NOT_FOUND; - } - TclWinConvertError(err); - if (interp != (Tcl_Interp *) NULL) { - Tcl_AppendResult(interp, "couldn't open \"", fileName, "\": ", - Tcl_PosixError(interp), (char *) NULL); - } - Tcl_DStringFree(&buffer); - return NULL; - } - - type = GetFileType(handle); - - /* - * If the file is a character device, we need to try to figure out - * whether it is a serial port, a console, or something else. We - * test for the console case first because this is more common. - */ - - if (type == FILE_TYPE_CHAR) { - if (GetConsoleMode(handle, &consoleParams)) { - type = FILE_TYPE_CONSOLE; - } else { - dcb.DCBlength = sizeof( DCB ) ; - if (GetCommState(handle, &dcb)) { - type = FILE_TYPE_SERIAL; - } - - } - } - - channel = NULL; - - switch (type) { - case FILE_TYPE_SERIAL: - channel = TclWinOpenSerialChannel(handle, channelName, - channelPermissions); - break; - case FILE_TYPE_CONSOLE: - channel = TclWinOpenConsoleChannel(handle, channelName, - channelPermissions); - break; - case FILE_TYPE_PIPE: - if (channelPermissions & TCL_READABLE) { - readFile = TclWinMakeFile(handle); - } - if (channelPermissions & TCL_WRITABLE) { - writeFile = TclWinMakeFile(handle); - } - channel = TclpCreateCommandChannel(readFile, writeFile, NULL, 0, NULL); - break; - case FILE_TYPE_CHAR: - case FILE_TYPE_DISK: - case FILE_TYPE_UNKNOWN: - channel = TclWinOpenFileChannel(handle, channelName, - channelPermissions, - (mode & O_APPEND) ? FILE_APPEND : 0); - break; - - default: - /* - * The handle is of an unknown type, probably /dev/nul equivalent - * or possibly a closed handle. - */ - - channel = NULL; - Tcl_AppendResult(interp, "couldn't open \"", fileName, "\": ", - "bad file type", (char *) NULL); - break; - } - - Tcl_DStringFree(&buffer); - Tcl_DStringFree(&ds); - - if (channel != NULL) { - if (seekFlag) { - if (Tcl_Seek(channel, 0, SEEK_END) < 0) { - if (interp != (Tcl_Interp *) NULL) { - Tcl_AppendResult(interp, - "could not seek to end of file on \"", - channelName, "\": ", Tcl_PosixError(interp), - (char *) NULL); - } - Tcl_Close(NULL, channel); - return NULL; - } - } - } - return channel; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_MakeFileChannel -- - * - * Creates a Tcl_Channel from an existing platform specific file - * handle. - * - * Results: - * The Tcl_Channel created around the preexisting file. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -Tcl_Channel -Tcl_MakeFileChannel(rawHandle, mode) - ClientData rawHandle; /* OS level handle */ - int mode; /* ORed combination of TCL_READABLE and - * TCL_WRITABLE to indicate file mode. */ -{ - char channelName[16 + TCL_INTEGER_SPACE]; - Tcl_Channel channel = NULL; - HANDLE handle = (HANDLE) rawHandle; - DCB dcb; - DWORD consoleParams; - DWORD type; - TclFile readFile = NULL; - TclFile writeFile = NULL; - - if (mode == 0) { - return NULL; - } - - type = GetFileType(handle); - - /* - * If the file is a character device, we need to try to figure out - * whether it is a serial port, a console, or something else. We - * test for the console case first because this is more common. - */ - - if (type == FILE_TYPE_CHAR) { - if (GetConsoleMode(handle, &consoleParams)) { - type = FILE_TYPE_CONSOLE; - } else { - dcb.DCBlength = sizeof( DCB ) ; - if (GetCommState(handle, &dcb)) { - type = FILE_TYPE_SERIAL; - } - } - } - - switch (type) - { - case FILE_TYPE_SERIAL: - channel = TclWinOpenSerialChannel(handle, channelName, mode); - break; - case FILE_TYPE_CONSOLE: - channel = TclWinOpenConsoleChannel(handle, channelName, mode); - break; - case FILE_TYPE_PIPE: - if (mode & TCL_READABLE) - { - readFile = TclWinMakeFile(handle); - } - if (mode & TCL_WRITABLE) - { - writeFile = TclWinMakeFile(handle); - } - channel = TclpCreateCommandChannel(readFile, writeFile, NULL, 0, NULL); - break; - - case FILE_TYPE_DISK: - case FILE_TYPE_CHAR: - case FILE_TYPE_UNKNOWN: - channel = TclWinOpenFileChannel(handle, channelName, mode, 0); - break; - - default: - /* - * The handle is of an unknown type, probably /dev/nul equivalent - * or possibly a closed handle. - */ - - channel = NULL; - break; - - } - - return channel; -} - -/* - *---------------------------------------------------------------------- - * - * TclpGetDefaultStdChannel -- - * - * Constructs a channel for the specified standard OS handle. - * - * Results: - * Returns the specified default standard channel, or NULL. - * - * Side effects: - * May cause the creation of a standard channel and the underlying - * file. - * - *---------------------------------------------------------------------- - */ - -Tcl_Channel -TclpGetDefaultStdChannel(type) - int type; /* One of TCL_STDIN, TCL_STDOUT, TCL_STDERR. */ -{ - Tcl_Channel channel; - HANDLE handle; - int mode; - char *bufMode; - DWORD handleId; /* Standard handle to retrieve. */ - - switch (type) { - case TCL_STDIN: - handleId = STD_INPUT_HANDLE; - mode = TCL_READABLE; - bufMode = "line"; - break; - case TCL_STDOUT: - handleId = STD_OUTPUT_HANDLE; - mode = TCL_WRITABLE; - bufMode = "line"; - break; - case TCL_STDERR: - handleId = STD_ERROR_HANDLE; - mode = TCL_WRITABLE; - bufMode = "none"; - break; - default: - panic("TclGetDefaultStdChannel: Unexpected channel type"); - break; - } - - handle = GetStdHandle(handleId); - - /* - * Note that we need to check for 0 because Windows may return 0 if this - * is not a console mode application, even though this is not a valid - * handle. - */ - - if ((handle == INVALID_HANDLE_VALUE) || (handle == 0)) { - return NULL; - } - - channel = Tcl_MakeFileChannel(handle, mode); - - if (channel == NULL) { - return NULL; - } - - /* - * Set up the normal channel options for stdio handles. - */ - - if ((Tcl_SetChannelOption((Tcl_Interp *) NULL, channel, "-translation", - "auto") == TCL_ERROR) - || (Tcl_SetChannelOption((Tcl_Interp *) NULL, channel, "-eofchar", - "\032 {}") == TCL_ERROR) - || (Tcl_SetChannelOption((Tcl_Interp *) NULL, channel, - "-buffering", bufMode) == TCL_ERROR)) { - Tcl_Close((Tcl_Interp *) NULL, channel); - return (Tcl_Channel) NULL; - } - return channel; -} - - - -/* - *---------------------------------------------------------------------- - * - * TclWinOpenFileChannel -- - * - * Constructs a File channel for the specified standard OS handle. - * This is a helper function to break up the construction of - * channels into File, Console, or Serial. - * - * Results: - * Returns the new channel, or NULL. - * - * Side effects: - * May open the channel and may cause creation of a file on the - * file system. - * - *---------------------------------------------------------------------- - */ - -Tcl_Channel -TclWinOpenFileChannel(handle, channelName, permissions, appendMode) - HANDLE handle; - char *channelName; - int permissions; - int appendMode; -{ - FileInfo *infoPtr; - ThreadSpecificData *tsdPtr; - - tsdPtr = FileInit(); - - /* - * See if a channel with this handle already exists. - */ - - for (infoPtr = tsdPtr->firstFilePtr; infoPtr != NULL; - infoPtr = infoPtr->nextPtr) { - if (infoPtr->handle == (HANDLE) handle) { - return (permissions == infoPtr->validMask) ? infoPtr->channel : NULL; - } - } - - infoPtr = (FileInfo *) ckalloc((unsigned) sizeof(FileInfo)); - infoPtr->nextPtr = tsdPtr->firstFilePtr; - tsdPtr->firstFilePtr = infoPtr; - infoPtr->validMask = permissions; - infoPtr->watchMask = 0; - infoPtr->flags = appendMode; - infoPtr->handle = handle; - - wsprintfA(channelName, "file%lx", (int) infoPtr); - - infoPtr->channel = Tcl_CreateChannel(&fileChannelType, channelName, - (ClientData) infoPtr, permissions); - - /* - * Files have default translation of AUTO and ^Z eof char, which - * means that a ^Z will be accepted as EOF when reading. - */ - - Tcl_SetChannelOption(NULL, infoPtr->channel, "-translation", "auto"); - Tcl_SetChannelOption(NULL, infoPtr->channel, "-eofchar", "\032 {}"); - - return infoPtr->channel; -} - diff --git a/win/tclWinConsole.c b/win/tclWinConsole.c deleted file mode 100644 index 579900e..0000000 --- a/win/tclWinConsole.c +++ /dev/null @@ -1,1278 +0,0 @@ -/* - * tclWinConsole.c -- - * - * This file implements the Windows-specific console functions, - * and the "console" channel driver. - * - * Copyright (c) 1999 by Scriptics Corp. - * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclWinConsole.c,v 1.3.10.1 2000/07/27 01:39:25 hobbs Exp $ - */ - -#include "tclWinInt.h" - -#include <dos.h> -#include <fcntl.h> -#include <io.h> -#include <sys/stat.h> - -/* - * The following variable is used to tell whether this module has been - * initialized. - */ - -static int initialized = 0; - -/* - * The consoleMutex locks around access to the initialized variable, and it is - * used to protect background threads from being terminated while they are - * using APIs that hold locks. - */ - -TCL_DECLARE_MUTEX(consoleMutex) - -/* - * Bit masks used in the flags field of the ConsoleInfo structure below. - */ - -#define CONSOLE_PENDING (1<<0) /* Message is pending in the queue. */ -#define CONSOLE_ASYNC (1<<1) /* Channel is non-blocking. */ - -/* - * Bit masks used in the sharedFlags field of the ConsoleInfo structure below. - */ - -#define CONSOLE_EOF (1<<2) /* Console has reached EOF. */ -#define CONSOLE_BUFFERED (1<<3) /* data was read into a buffer by the reader - thread */ - -#define CONSOLE_BUFFER_SIZE (8*1024) -/* - * This structure describes per-instance data for a console based channel. - */ - -typedef struct ConsoleInfo { - HANDLE handle; - int type; - struct ConsoleInfo *nextPtr;/* Pointer to next registered console. */ - Tcl_Channel channel; /* Pointer to channel structure. */ - int validMask; /* OR'ed combination of TCL_READABLE, - * TCL_WRITABLE, or TCL_EXCEPTION: indicates - * which operations are valid on the file. */ - int watchMask; /* OR'ed combination of TCL_READABLE, - * TCL_WRITABLE, or TCL_EXCEPTION: indicates - * which events should be reported. */ - int flags; /* State flags, see above for a list. */ - Tcl_ThreadId threadId; /* Thread to which events should be reported. - * This value is used by the reader/writer - * threads. */ - HANDLE writeThread; /* Handle to writer thread. */ - HANDLE readThread; /* Handle to reader thread. */ - HANDLE writable; /* Manual-reset event to signal when the - * writer thread has finished waiting for - * the current buffer to be written. */ - HANDLE readable; /* Manual-reset event to signal when the - * reader thread has finished waiting for - * input. */ - HANDLE startWriter; /* Auto-reset event used by the main thread to - * signal when the writer thread should attempt - * to write to the console. */ - HANDLE startReader; /* Auto-reset event used by the main thread to - * signal when the reader thread should attempt - * to read from the console. */ - DWORD writeError; /* An error caused by the last background - * write. Set to 0 if no error has been - * detected. This word is shared with the - * writer thread so access must be - * synchronized with the writable object. - */ - char *writeBuf; /* Current background output buffer. - * Access is synchronized with the writable - * object. */ - int writeBufLen; /* Size of write buffer. Access is - * synchronized with the writable - * object. */ - int toWrite; /* Current amount to be written. Access is - * synchronized with the writable object. */ - int readFlags; /* Flags that are shared with the reader - * thread. Access is synchronized with the - * readable object. */ - int bytesRead; /* number of bytes in the buffer */ - int offset; /* number of bytes read out of the buffer */ - char buffer[CONSOLE_BUFFER_SIZE]; - /* Data consumed by reader thread. */ -} ConsoleInfo; - -typedef struct ThreadSpecificData { - /* - * The following pointer refers to the head of the list of consoles - * that are being watched for file events. - */ - - ConsoleInfo *firstConsolePtr; -} ThreadSpecificData; - -static Tcl_ThreadDataKey dataKey; - -/* - * The following structure is what is added to the Tcl event queue when - * console events are generated. - */ - -typedef struct ConsoleEvent { - Tcl_Event header; /* Information that is standard for - * all events. */ - ConsoleInfo *infoPtr; /* Pointer to console info structure. Note - * that we still have to verify that the - * console exists before dereferencing this - * pointer. */ -} ConsoleEvent; - -/* - * Declarations for functions used only in this file. - */ - -static int ApplicationType(Tcl_Interp *interp, - const char *fileName, char *fullName); -static void BuildCommandLine(const char *executable, int argc, - char **argv, Tcl_DString *linePtr); -static void CopyChannel(HANDLE dst, HANDLE src); -static BOOL HasConsole(void); -static TclFile MakeFile(HANDLE handle); -static char * MakeTempFile(Tcl_DString *namePtr); -static int ConsoleBlockModeProc(ClientData instanceData, int mode); -static void ConsoleCheckProc(ClientData clientData, int flags); -static int ConsoleCloseProc(ClientData instanceData, - Tcl_Interp *interp); -static int ConsoleEventProc(Tcl_Event *evPtr, int flags); -static void ConsoleExitHandler(ClientData clientData); -static int ConsoleGetHandleProc(ClientData instanceData, - int direction, ClientData *handlePtr); -static ThreadSpecificData *ConsoleInit(void); -static int ConsoleInputProc(ClientData instanceData, char *buf, - int toRead, int *errorCode); -static int ConsoleOutputProc(ClientData instanceData, char *buf, - int toWrite, int *errorCode); -static DWORD WINAPI ConsoleReaderThread(LPVOID arg); -static void ConsoleSetupProc(ClientData clientData, int flags); -static void ConsoleWatchProc(ClientData instanceData, int mask); -static DWORD WINAPI ConsoleWriterThread(LPVOID arg); -static void ProcExitHandler(ClientData clientData); -static int TempFileName(WCHAR name[MAX_PATH]); -static int WaitForRead(ConsoleInfo *infoPtr, int blocking); - -/* - * This structure describes the channel type structure for command console - * based IO. - */ - -static Tcl_ChannelType consoleChannelType = { - "console", /* Type name. */ - TCL_CHANNEL_VERSION_2, /* v2 channel */ - ConsoleCloseProc, /* Close proc. */ - ConsoleInputProc, /* Input proc. */ - ConsoleOutputProc, /* Output proc. */ - NULL, /* Seek proc. */ - NULL, /* Set option proc. */ - NULL, /* Get option proc. */ - ConsoleWatchProc, /* Set up notifier to watch the channel. */ - ConsoleGetHandleProc, /* Get an OS handle from channel. */ - NULL, /* close2proc. */ - ConsoleBlockModeProc, /* Set blocking or non-blocking mode.*/ - NULL, /* flush proc. */ - NULL, /* handler proc. */ -}; - -/* - *---------------------------------------------------------------------- - * - * ConsoleInit -- - * - * This function initializes the static variables for this file. - * - * Results: - * None. - * - * Side effects: - * Creates a new event source. - * - *---------------------------------------------------------------------- - */ - -static ThreadSpecificData * -ConsoleInit() -{ - ThreadSpecificData *tsdPtr; - - /* - * Check the initialized flag first, then check again in the mutex. - * This is a speed enhancement. - */ - - if (!initialized) { - Tcl_MutexLock(&consoleMutex); - if (!initialized) { - initialized = 1; - Tcl_CreateExitHandler(ProcExitHandler, NULL); - } - Tcl_MutexUnlock(&consoleMutex); - } - - tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey); - if (tsdPtr == NULL) { - tsdPtr = TCL_TSD_INIT(&dataKey); - tsdPtr->firstConsolePtr = NULL; - Tcl_CreateEventSource(ConsoleSetupProc, ConsoleCheckProc, NULL); - Tcl_CreateThreadExitHandler(ConsoleExitHandler, NULL); - } - return tsdPtr; -} - -/* - *---------------------------------------------------------------------- - * - * ConsoleExitHandler -- - * - * This function is called to cleanup the console module before - * Tcl is unloaded. - * - * Results: - * None. - * - * Side effects: - * Removes the console event source. - * - *---------------------------------------------------------------------- - */ - -static void -ConsoleExitHandler( - ClientData clientData) /* Old window proc */ -{ - Tcl_DeleteEventSource(ConsoleSetupProc, ConsoleCheckProc, NULL); -} - -/* - *---------------------------------------------------------------------- - * - * ProcExitHandler -- - * - * This function is called to cleanup the process list before - * Tcl is unloaded. - * - * Results: - * None. - * - * Side effects: - * Resets the process list. - * - *---------------------------------------------------------------------- - */ - -static void -ProcExitHandler( - ClientData clientData) /* Old window proc */ -{ - Tcl_MutexLock(&consoleMutex); - initialized = 0; - Tcl_MutexUnlock(&consoleMutex); -} - -/* - *---------------------------------------------------------------------- - * - * ConsoleSetupProc -- - * - * This procedure is invoked before Tcl_DoOneEvent blocks waiting - * for an event. - * - * Results: - * None. - * - * Side effects: - * Adjusts the block time if needed. - * - *---------------------------------------------------------------------- - */ - -void -ConsoleSetupProc( - ClientData data, /* Not used. */ - int flags) /* Event flags as passed to Tcl_DoOneEvent. */ -{ - ConsoleInfo *infoPtr; - Tcl_Time blockTime = { 0, 0 }; - int block = 1; - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - - if (!(flags & TCL_FILE_EVENTS)) { - return; - } - - /* - * Look to see if any events are already pending. If they are, poll. - */ - - for (infoPtr = tsdPtr->firstConsolePtr; infoPtr != NULL; - infoPtr = infoPtr->nextPtr) { - if (infoPtr->watchMask & TCL_WRITABLE) { - if (WaitForSingleObject(infoPtr->writable, 0) != WAIT_TIMEOUT) { - block = 0; - } - } - if (infoPtr->watchMask & TCL_READABLE) { - if (WaitForRead(infoPtr, 0) >= 0) { - block = 0; - } - } - } - if (!block) { - Tcl_SetMaxBlockTime(&blockTime); - } -} - -/* - *---------------------------------------------------------------------- - * - * ConsoleCheckProc -- - * - * This procedure is called by Tcl_DoOneEvent to check the console - * event source for events. - * - * Results: - * None. - * - * Side effects: - * May queue an event. - * - *---------------------------------------------------------------------- - */ - -static void -ConsoleCheckProc( - ClientData data, /* Not used. */ - int flags) /* Event flags as passed to Tcl_DoOneEvent. */ -{ - ConsoleInfo *infoPtr; - ConsoleEvent *evPtr; - int needEvent; - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - - if (!(flags & TCL_FILE_EVENTS)) { - return; - } - - /* - * Queue events for any ready consoles that don't already have events - * queued. - */ - - for (infoPtr = tsdPtr->firstConsolePtr; infoPtr != NULL; - infoPtr = infoPtr->nextPtr) { - if (infoPtr->flags & CONSOLE_PENDING) { - continue; - } - - /* - * Queue an event if the console is signaled for reading or writing. - */ - - needEvent = 0; - if (infoPtr->watchMask & TCL_WRITABLE) { - if (WaitForSingleObject(infoPtr->writable, 0) != WAIT_TIMEOUT) { - needEvent = 1; - } - } - - if (infoPtr->watchMask & TCL_READABLE) { - if (WaitForRead(infoPtr, 0) >= 0) { - needEvent = 1; - } - } - - if (needEvent) { - infoPtr->flags |= CONSOLE_PENDING; - evPtr = (ConsoleEvent *) ckalloc(sizeof(ConsoleEvent)); - evPtr->header.proc = ConsoleEventProc; - evPtr->infoPtr = infoPtr; - Tcl_QueueEvent((Tcl_Event *) evPtr, TCL_QUEUE_TAIL); - } - } -} - - -/* - *---------------------------------------------------------------------- - * - * ConsoleBlockModeProc -- - * - * Set blocking or non-blocking mode on channel. - * - * Results: - * 0 if successful, errno when failed. - * - * Side effects: - * Sets the device into blocking or non-blocking mode. - * - *---------------------------------------------------------------------- - */ - -static int -ConsoleBlockModeProc( - ClientData instanceData, /* Instance data for channel. */ - int mode) /* TCL_MODE_BLOCKING or - * TCL_MODE_NONBLOCKING. */ -{ - ConsoleInfo *infoPtr = (ConsoleInfo *) instanceData; - - /* - * Consoles on Windows can not be switched between blocking and nonblocking, - * hence we have to emulate the behavior. This is done in the input - * function by checking against a bit in the state. We set or unset the - * bit here to cause the input function to emulate the correct behavior. - */ - - if (mode == TCL_MODE_NONBLOCKING) { - infoPtr->flags |= CONSOLE_ASYNC; - } else { - infoPtr->flags &= ~(CONSOLE_ASYNC); - } - return 0; -} - -/* - *---------------------------------------------------------------------- - * - * ConsoleCloseProc -- - * - * Closes a console based IO channel. - * - * Results: - * 0 on success, errno otherwise. - * - * Side effects: - * Closes the physical channel. - * - *---------------------------------------------------------------------- - */ - -static int -ConsoleCloseProc( - ClientData instanceData, /* Pointer to ConsoleInfo structure. */ - Tcl_Interp *interp) /* For error reporting. */ -{ - ConsoleInfo *consolePtr = (ConsoleInfo *) instanceData; - int errorCode; - ConsoleInfo *infoPtr, **nextPtrPtr; - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - - errorCode = 0; - - /* - * Clean up the background thread if necessary. Note that this - * must be done before we can close the file, since the - * thread may be blocking trying to read from the console. - */ - - if (consolePtr->readThread) { - /* - * Forcibly terminate the background thread. We cannot rely on the - * thread to cleanly terminate itself because we have no way of - * closing the handle without blocking in the case where the - * thread is in the middle of an I/O operation. Note that we need - * to guard against terminating the thread while it is in the - * middle of Tcl_ThreadAlert because it won't be able to release - * the notifier lock. - */ - - Tcl_MutexLock(&consoleMutex); - TerminateThread(consolePtr->readThread, 0); - - /* - * Wait for the thread to terminate. This ensures that we are - * completely cleaned up before we leave this function. - */ - - WaitForSingleObject(consolePtr->readThread, INFINITE); - Tcl_MutexUnlock(&consoleMutex); - - CloseHandle(consolePtr->readThread); - CloseHandle(consolePtr->readable); - CloseHandle(consolePtr->startReader); - consolePtr->readThread = NULL; - } - consolePtr->validMask &= ~TCL_READABLE; - - /* - * Wait for the writer thread to finish the current buffer, then - * terminate the thread and close the handles. If the channel is - * nonblocking, there should be no pending write operations. - */ - - if (consolePtr->writeThread) { - WaitForSingleObject(consolePtr->writable, INFINITE); - - /* - * Forcibly terminate the background thread. We cannot rely on the - * thread to cleanly terminate itself because we have no way of - * closing the handle without blocking in the case where the - * thread is in the middle of an I/O operation. Note that we need - * to guard against terminating the thread while it is in the - * middle of Tcl_ThreadAlert because it won't be able to release - * the notifier lock. - */ - - Tcl_MutexLock(&consoleMutex); - TerminateThread(consolePtr->writeThread, 0); - - /* - * Wait for the thread to terminate. This ensures that we are - * completely cleaned up before we leave this function. - */ - - WaitForSingleObject(consolePtr->writeThread, INFINITE); - Tcl_MutexUnlock(&consoleMutex); - - CloseHandle(consolePtr->writeThread); - CloseHandle(consolePtr->writable); - CloseHandle(consolePtr->startWriter); - consolePtr->writeThread = NULL; - } - consolePtr->validMask &= ~TCL_WRITABLE; - - - /* - * Don't close the Win32 handle if the handle is a standard channel - * during the exit process. Otherwise, one thread may kill the stdio - * of another. - */ - - if (!TclInExit() - || ((GetStdHandle(STD_INPUT_HANDLE) != consolePtr->handle) - && (GetStdHandle(STD_OUTPUT_HANDLE) != consolePtr->handle) - && (GetStdHandle(STD_ERROR_HANDLE) != consolePtr->handle))) { - if (CloseHandle(consolePtr->handle) == FALSE) { - TclWinConvertError(GetLastError()); - errorCode = errno; - } - } - - consolePtr->watchMask &= consolePtr->validMask; - - /* - * Remove the file from the list of watched files. - */ - - for (nextPtrPtr = &(tsdPtr->firstConsolePtr), infoPtr = *nextPtrPtr; - infoPtr != NULL; - nextPtrPtr = &infoPtr->nextPtr, infoPtr = *nextPtrPtr) { - if (infoPtr == (ConsoleInfo *)consolePtr) { - *nextPtrPtr = infoPtr->nextPtr; - break; - } - } - if (consolePtr->writeBuf != NULL) { - ckfree(consolePtr->writeBuf); - consolePtr->writeBuf = 0; - } - ckfree((char*) consolePtr); - - return errorCode; -} - -/* - *---------------------------------------------------------------------- - * - * ConsoleInputProc -- - * - * Reads input from the IO channel into the buffer given. Returns - * count of how many bytes were actually read, and an error indication. - * - * Results: - * A count of how many bytes were read is returned and an error - * indication is returned in an output argument. - * - * Side effects: - * Reads input from the actual channel. - * - *---------------------------------------------------------------------- - */ - -static int -ConsoleInputProc( - ClientData instanceData, /* Console state. */ - char *buf, /* Where to store data read. */ - int bufSize, /* How much space is available - * in the buffer? */ - int *errorCode) /* Where to store error code. */ -{ - ConsoleInfo *infoPtr = (ConsoleInfo *) instanceData; - DWORD count, bytesRead = 0; - int result; - - *errorCode = 0; - - /* - * Synchronize with the reader thread. - */ - - result = WaitForRead(infoPtr, (infoPtr->flags & CONSOLE_ASYNC) ? 0 : 1); - - /* - * If an error occurred, return immediately. - */ - - if (result == -1) { - *errorCode = errno; - return -1; - } - - if (infoPtr->readFlags & CONSOLE_BUFFERED) { - /* - * Data is stored in the buffer. - */ - - if (bufSize < (infoPtr->bytesRead - infoPtr->offset)) { - memcpy(buf, &infoPtr->buffer[infoPtr->offset], bufSize); - bytesRead = bufSize; - infoPtr->offset += bufSize; - } else { - memcpy(buf, &infoPtr->buffer[infoPtr->offset], bufSize); - bytesRead = infoPtr->bytesRead - infoPtr->offset; - - /* - * Reset the buffer - */ - - infoPtr->readFlags &= ~CONSOLE_BUFFERED; - infoPtr->offset = 0; - } - - return bytesRead; - } - - /* - * Attempt to read bufSize bytes. The read will return immediately - * if there is any data available. Otherwise it will block until - * at least one byte is available or an EOF occurs. - */ - - if (ReadConsole(infoPtr->handle, (LPVOID) buf, (DWORD) bufSize, &count, - (LPOVERLAPPED) NULL) == TRUE) { - buf[count] = '\0'; - return count; - } - - return -1; -} - -/* - *---------------------------------------------------------------------- - * - * ConsoleOutputProc -- - * - * Writes the given output on the IO channel. Returns count of how - * many characters were actually written, and an error indication. - * - * Results: - * A count of how many characters were written is returned and an - * error indication is returned in an output argument. - * - * Side effects: - * Writes output on the actual channel. - * - *---------------------------------------------------------------------- - */ - -static int -ConsoleOutputProc( - ClientData instanceData, /* Console state. */ - char *buf, /* The data buffer. */ - int toWrite, /* How many bytes to write? */ - int *errorCode) /* Where to store error code. */ -{ - ConsoleInfo *infoPtr = (ConsoleInfo *) instanceData; - DWORD bytesWritten, timeout; - - *errorCode = 0; - timeout = (infoPtr->flags & CONSOLE_ASYNC) ? 0 : INFINITE; - if (WaitForSingleObject(infoPtr->writable, timeout) == WAIT_TIMEOUT) { - /* - * The writer thread is blocked waiting for a write to complete - * and the channel is in non-blocking mode. - */ - - errno = EAGAIN; - goto error; - } - - /* - * Check for a background error on the last write. - */ - - if (infoPtr->writeError) { - TclWinConvertError(infoPtr->writeError); - infoPtr->writeError = 0; - goto error; - } - - if (infoPtr->flags & CONSOLE_ASYNC) { - /* - * The console is non-blocking, so copy the data into the output - * buffer and restart the writer thread. - */ - - if (toWrite > infoPtr->writeBufLen) { - /* - * Reallocate the buffer to be large enough to hold the data. - */ - - if (infoPtr->writeBuf) { - ckfree(infoPtr->writeBuf); - } - infoPtr->writeBufLen = toWrite; - infoPtr->writeBuf = ckalloc(toWrite); - } - memcpy(infoPtr->writeBuf, buf, toWrite); - infoPtr->toWrite = toWrite; - ResetEvent(infoPtr->writable); - SetEvent(infoPtr->startWriter); - bytesWritten = toWrite; - } else { - /* - * In the blocking case, just try to write the buffer directly. - * This avoids an unnecessary copy. - */ - - if (WriteFile(infoPtr->handle, (LPVOID) buf, (DWORD) toWrite, - &bytesWritten, (LPOVERLAPPED) NULL) == FALSE) { - TclWinConvertError(GetLastError()); - goto error; - } - } - return bytesWritten; - - error: - *errorCode = errno; - return -1; - -} - -/* - *---------------------------------------------------------------------- - * - * ConsoleEventProc -- - * - * This function is invoked by Tcl_ServiceEvent when a file event - * reaches the front of the event queue. This procedure invokes - * Tcl_NotifyChannel on the console. - * - * Results: - * Returns 1 if the event was handled, meaning it should be removed - * from the queue. Returns 0 if the event was not handled, meaning - * it should stay on the queue. The only time the event isn't - * handled is if the TCL_FILE_EVENTS flag bit isn't set. - * - * Side effects: - * Whatever the notifier callback does. - * - *---------------------------------------------------------------------- - */ - -static int -ConsoleEventProc( - Tcl_Event *evPtr, /* Event to service. */ - int flags) /* Flags that indicate what events to - * handle, such as TCL_FILE_EVENTS. */ -{ - ConsoleEvent *consoleEvPtr = (ConsoleEvent *)evPtr; - ConsoleInfo *infoPtr; - int mask; - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - - if (!(flags & TCL_FILE_EVENTS)) { - return 0; - } - - /* - * Search through the list of watched consoles for the one whose handle - * matches the event. We do this rather than simply dereferencing - * the handle in the event so that consoles can be deleted while the - * event is in the queue. - */ - - for (infoPtr = tsdPtr->firstConsolePtr; infoPtr != NULL; - infoPtr = infoPtr->nextPtr) { - if (consoleEvPtr->infoPtr == infoPtr) { - infoPtr->flags &= ~(CONSOLE_PENDING); - break; - } - } - - /* - * Remove stale events. - */ - - if (!infoPtr) { - return 1; - } - - /* - * Check to see if the console is readable. Note - * that we can't tell if a console is writable, so we always report it - * as being writable unless we have detected EOF. - */ - - mask = 0; - if (infoPtr->watchMask & TCL_WRITABLE) { - if (WaitForSingleObject(infoPtr->writable, 0) != WAIT_TIMEOUT) { - mask = TCL_WRITABLE; - } - } - - if (infoPtr->watchMask & TCL_READABLE) { - if (WaitForRead(infoPtr, 0) >= 0) { - if (infoPtr->readFlags & CONSOLE_EOF) { - mask = TCL_READABLE; - } else { - mask |= TCL_READABLE; - } - } - } - - /* - * Inform the channel of the events. - */ - - Tcl_NotifyChannel(infoPtr->channel, infoPtr->watchMask & mask); - return 1; -} - -/* - *---------------------------------------------------------------------- - * - * ConsoleWatchProc -- - * - * Called by the notifier to set up to watch for events on this - * channel. - * - * Results: - * None. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static void -ConsoleWatchProc( - ClientData instanceData, /* Console state. */ - int mask) /* What events to watch for, OR-ed - * combination of TCL_READABLE, - * TCL_WRITABLE and TCL_EXCEPTION. */ -{ - ConsoleInfo **nextPtrPtr, *ptr; - ConsoleInfo *infoPtr = (ConsoleInfo *) instanceData; - int oldMask = infoPtr->watchMask; - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - - /* - * Since most of the work is handled by the background threads, - * we just need to update the watchMask and then force the notifier - * to poll once. - */ - - infoPtr->watchMask = mask & infoPtr->validMask; - if (infoPtr->watchMask) { - Tcl_Time blockTime = { 0, 0 }; - if (!oldMask) { - infoPtr->nextPtr = tsdPtr->firstConsolePtr; - tsdPtr->firstConsolePtr = infoPtr; - } - Tcl_SetMaxBlockTime(&blockTime); - } else { - if (oldMask) { - /* - * Remove the console from the list of watched consoles. - */ - - for (nextPtrPtr = &(tsdPtr->firstConsolePtr), ptr = *nextPtrPtr; - ptr != NULL; - nextPtrPtr = &ptr->nextPtr, ptr = *nextPtrPtr) { - if (infoPtr == ptr) { - *nextPtrPtr = ptr->nextPtr; - break; - } - } - } - } -} - -/* - *---------------------------------------------------------------------- - * - * ConsoleGetHandleProc -- - * - * Called from Tcl_GetChannelHandle to retrieve OS handles from - * inside a command consoleline based channel. - * - * Results: - * Returns TCL_OK with the fd in handlePtr, or TCL_ERROR if - * there is no handle for the specified direction. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -ConsoleGetHandleProc( - ClientData instanceData, /* The console state. */ - int direction, /* TCL_READABLE or TCL_WRITABLE */ - ClientData *handlePtr) /* Where to store the handle. */ -{ - ConsoleInfo *infoPtr = (ConsoleInfo *) instanceData; - - *handlePtr = (ClientData) infoPtr->handle; - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * WaitForRead -- - * - * Wait until some data is available, the console is at - * EOF or the reader thread is blocked waiting for data (if the - * channel is in non-blocking mode). - * - * Results: - * Returns 1 if console is readable. Returns 0 if there is no data - * on the console, but there is buffered data. Returns -1 if an - * error occurred. If an error occurred, the threads may not - * be synchronized. - * - * Side effects: - * Updates the shared state flags. If no error occurred, - * the reader thread is blocked waiting for a signal from the - * main thread. - * - *---------------------------------------------------------------------- - */ - -static int -WaitForRead( - ConsoleInfo *infoPtr, /* Console state. */ - int blocking) /* Indicates whether call should be - * blocking or not. */ -{ - DWORD timeout, count; - HANDLE *handle = infoPtr->handle; - INPUT_RECORD input; - - while (1) { - /* - * Synchronize with the reader thread. - */ - - timeout = blocking ? INFINITE : 0; - if (WaitForSingleObject(infoPtr->readable, timeout) == WAIT_TIMEOUT) { - /* - * The reader thread is blocked waiting for data and the channel - * is in non-blocking mode. - */ - errno = EAGAIN; - return -1; - } - - /* - * At this point, the two threads are synchronized, so it is safe - * to access shared state. - */ - - /* - * If the console has hit EOF, it is always readable. - */ - - if (infoPtr->readFlags & CONSOLE_EOF) { - return 1; - } - - if (PeekConsoleInput(handle, &input, 1, &count) == FALSE) { - /* - * Check to see if the peek failed because of EOF. - */ - - TclWinConvertError(GetLastError()); - - if (errno == EOF) { - infoPtr->readFlags |= CONSOLE_EOF; - return 1; - } - - /* - * Ignore errors if there is data in the buffer. - */ - - if (infoPtr->readFlags & CONSOLE_BUFFERED) { - return 0; - } else { - return -1; - } - } - - /* - * If there is data in the buffer, the console must be - * readable (since it is a line-oriented device). - */ - - if (infoPtr->readFlags & CONSOLE_BUFFERED) { - return 1; - } - - - /* - * There wasn't any data available, so reset the thread and - * try again. - */ - - ResetEvent(infoPtr->readable); - SetEvent(infoPtr->startReader); - } -} - -/* - *---------------------------------------------------------------------- - * - * ConsoleReaderThread -- - * - * This function runs in a separate thread and waits for input - * to become available on a console. - * - * Results: - * None. - * - * Side effects: - * Signals the main thread when input become available. May - * cause the main thread to wake up by posting a message. May - * one line from the console for each wait operation. - * - *---------------------------------------------------------------------- - */ - -static DWORD WINAPI -ConsoleReaderThread(LPVOID arg) -{ - ConsoleInfo *infoPtr = (ConsoleInfo *)arg; - HANDLE *handle = infoPtr->handle; - DWORD count; - - for (;;) { - /* - * Wait for the main thread to signal before attempting to wait. - */ - - WaitForSingleObject(infoPtr->startReader, INFINITE); - - count = 0; - - /* - * Look for data on the console, but first ignore any events - * that are not KEY_EVENTs - */ - if (ReadConsole(handle, infoPtr->buffer, CONSOLE_BUFFER_SIZE, - &infoPtr->bytesRead, NULL) != FALSE) { - /* - * Data was stored in the buffer. - */ - - infoPtr->readFlags |= CONSOLE_BUFFERED; - } else { - DWORD err; - err = GetLastError(); - - if (err == EOF) { - infoPtr->readFlags = CONSOLE_EOF; - } - } - - /* - * Signal the main thread by signalling the readable event and - * then waking up the notifier thread. - */ - - SetEvent(infoPtr->readable); - - /* - * Alert the foreground thread. Note that we need to treat this like - * a critical section so the foreground thread does not terminate - * this thread while we are holding a mutex in the notifier code. - */ - - Tcl_MutexLock(&consoleMutex); - Tcl_ThreadAlert(infoPtr->threadId); - Tcl_MutexUnlock(&consoleMutex); - } - return 0; /* NOT REACHED */ -} - -/* - *---------------------------------------------------------------------- - * - * ConsoleWriterThread -- - * - * This function runs in a separate thread and writes data - * onto a console. - * - * Results: - * Always returns 0. - * - * Side effects: - * Signals the main thread when an output operation is completed. - * May cause the main thread to wake up by posting a message. - * - *---------------------------------------------------------------------- - */ - -static DWORD WINAPI -ConsoleWriterThread(LPVOID arg) -{ - - ConsoleInfo *infoPtr = (ConsoleInfo *)arg; - HANDLE *handle = infoPtr->handle; - DWORD count, toWrite; - char *buf; - - for (;;) { - /* - * Wait for the main thread to signal before attempting to write. - */ - - WaitForSingleObject(infoPtr->startWriter, INFINITE); - - buf = infoPtr->writeBuf; - toWrite = infoPtr->toWrite; - - /* - * Loop until all of the bytes are written or an error occurs. - */ - - while (toWrite > 0) { - if (WriteFile(handle, buf, toWrite, &count, NULL) == FALSE) { - infoPtr->writeError = GetLastError(); - break; - } else { - toWrite -= count; - buf += count; - } - } - - /* - * Signal the main thread by signalling the writable event and - * then waking up the notifier thread. - */ - - SetEvent(infoPtr->writable); - - /* - * Alert the foreground thread. Note that we need to treat this like - * a critical section so the foreground thread does not terminate - * this thread while we are holding a mutex in the notifier code. - */ - - Tcl_MutexLock(&consoleMutex); - Tcl_ThreadAlert(infoPtr->threadId); - Tcl_MutexUnlock(&consoleMutex); - } - return 0; /* NOT REACHED */ -} - - - -/* - *---------------------------------------------------------------------- - * - * TclWinOpenConsoleChannel -- - * - * Constructs a Console channel for the specified standard OS handle. - * This is a helper function to break up the construction of - * channels into File, Console, or Serial. - * - * Results: - * Returns the new channel, or NULL. - * - * Side effects: - * May open the channel - * - *---------------------------------------------------------------------- - */ - -Tcl_Channel -TclWinOpenConsoleChannel(handle, channelName, permissions) - HANDLE handle; - char *channelName; - int permissions; -{ - char encoding[4 + TCL_INTEGER_SPACE]; - ConsoleInfo *infoPtr; - ThreadSpecificData *tsdPtr; - DWORD id; - - tsdPtr = ConsoleInit(); - - /* - * See if a channel with this handle already exists. - */ - - infoPtr = (ConsoleInfo *) ckalloc((unsigned) sizeof(ConsoleInfo)); - memset(infoPtr, 0, sizeof(ConsoleInfo)); - - infoPtr->validMask = permissions; - infoPtr->handle = handle; - - wsprintfA(encoding, "cp%d", GetConsoleCP()); - - /* - * Use the pointer for the name of the result channel. - * This keeps the channel names unique, since some may share - * handles (stdin/stdout/stderr for instance). - */ - - wsprintfA(channelName, "file%lx", (int) infoPtr); - - infoPtr->channel = Tcl_CreateChannel(&consoleChannelType, channelName, - (ClientData) infoPtr, permissions); - - infoPtr->threadId = Tcl_GetCurrentThread(); - - if (permissions & TCL_READABLE) { - infoPtr->readable = CreateEvent(NULL, TRUE, TRUE, NULL); - infoPtr->startReader = CreateEvent(NULL, FALSE, FALSE, NULL); - infoPtr->readThread = CreateThread(NULL, 8000, ConsoleReaderThread, - infoPtr, 0, &id); - SetThreadPriority(infoPtr->readThread, THREAD_PRIORITY_HIGHEST); - } - - if (permissions & TCL_WRITABLE) { - infoPtr->writable = CreateEvent(NULL, TRUE, TRUE, NULL); - infoPtr->startWriter = CreateEvent(NULL, FALSE, FALSE, NULL); - infoPtr->writeThread = CreateThread(NULL, 8000, ConsoleWriterThread, - infoPtr, 0, &id); - } - - /* - * Files have default translation of AUTO and ^Z eof char, which - * means that a ^Z will be accepted as EOF when reading. - */ - - Tcl_SetChannelOption(NULL, infoPtr->channel, "-translation", "auto"); - Tcl_SetChannelOption(NULL, infoPtr->channel, "-eofchar", "\032 {}"); - Tcl_SetChannelOption(NULL, infoPtr->channel, "-encoding", encoding); - - return infoPtr->channel; -} diff --git a/win/tclWinDde.c b/win/tclWinDde.c deleted file mode 100644 index 2eaf974..0000000 --- a/win/tclWinDde.c +++ /dev/null @@ -1,1351 +0,0 @@ -/* - * tclWinDde.c -- - * - * This file provides procedures that implement the "send" - * command, allowing commands to be passed from interpreter - * to interpreter. - * - * Copyright (c) 1997 by Sun Microsystems, Inc. - * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclWinDde.c,v 1.5 1999/06/26 22:41:53 redman Exp $ - */ - -#include "tclPort.h" -#include <ddeml.h> - -/* - * TCL_STORAGE_CLASS is set unconditionally to DLLEXPORT because the - * Registry_Init declaration is in the source file itself, which is only - * accessed when we are building a library. - */ - -#undef TCL_STORAGE_CLASS -#define TCL_STORAGE_CLASS DLLEXPORT - -/* - * The following structure is used to keep track of the interpreters - * registered by this process. - */ - -typedef struct RegisteredInterp { - struct RegisteredInterp *nextPtr; - /* The next interp this application knows - * about. */ - char *name; /* Interpreter's name (malloc-ed). */ - Tcl_Interp *interp; /* The interpreter attached to this name. */ -} RegisteredInterp; - -/* - * Used to keep track of conversations. - */ - -typedef struct Conversation { - struct Conversation *nextPtr; - /* The next conversation in the list. */ - RegisteredInterp *riPtr; /* The info we know about the conversation. */ - HCONV hConv; /* The DDE handle for this conversation. */ - Tcl_Obj *returnPackagePtr; /* The result package for this conversation. */ -} Conversation; - -typedef struct ThreadSpecificData { - Conversation *currentConversations; - /* A list of conversations currently - * being processed. */ - RegisteredInterp *interpListPtr; - /* List of all interpreters registered - * in the current process. */ -} ThreadSpecificData; -static Tcl_ThreadDataKey dataKey; - -/* - * The following variables cannot be placed in thread-local storage. - * The Mutex ddeMutex guards access to the ddeInstance. - */ -static HSZ ddeServiceGlobal = 0; -static DWORD ddeInstance; /* The application instance handle given - * to us by DdeInitialize. */ -static int ddeIsServer = 0; - -#define TCL_DDE_VERSION "1.1" -#define TCL_DDE_PACKAGE_NAME "dde" -#define TCL_DDE_SERVICE_NAME "TclEval" - -TCL_DECLARE_MUTEX(ddeMutex) - -/* - * Forward declarations for procedures defined later in this file. - */ - -static void DdeExitProc _ANSI_ARGS_((ClientData clientData)); -static void DeleteProc _ANSI_ARGS_((ClientData clientData)); -static Tcl_Obj * ExecuteRemoteObject _ANSI_ARGS_(( - RegisteredInterp *riPtr, - Tcl_Obj *ddeObjectPtr)); -static int MakeDdeConnection _ANSI_ARGS_((Tcl_Interp *interp, - char *name, HCONV *ddeConvPtr)); -static HDDEDATA CALLBACK DdeServerProc _ANSI_ARGS_((UINT uType, - UINT uFmt, HCONV hConv, HSZ ddeTopic, - HSZ ddeItem, HDDEDATA hData, DWORD dwData1, - DWORD dwData2)); -static void SetDdeError _ANSI_ARGS_((Tcl_Interp *interp)); -int Tcl_DdeObjCmd(ClientData clientData, /* Used only for deletion */ - Tcl_Interp *interp, /* The interp we are sending from */ - int objc, /* Number of arguments */ - Tcl_Obj *CONST objv[]); /* The arguments */ - -EXTERN int Dde_Init(Tcl_Interp *interp); - -/* - *---------------------------------------------------------------------- - * - * Dde_Init -- - * - * This procedure initializes the dde command. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -Dde_Init( - Tcl_Interp *interp) -{ - ThreadSpecificData *tsdPtr; - - if (!Tcl_InitStubs(interp, "8.0", 0)) { - return TCL_ERROR; - } - - Tcl_CreateObjCommand(interp, "dde", Tcl_DdeObjCmd, NULL, NULL); - - tsdPtr = (ThreadSpecificData *) - Tcl_GetThreadData((Tcl_ThreadDataKey *) &dataKey, sizeof(ThreadSpecificData)); - - if (tsdPtr == NULL) { - tsdPtr = TCL_TSD_INIT(&dataKey); - tsdPtr->currentConversations = NULL; - tsdPtr->interpListPtr = NULL; - } - Tcl_CreateExitHandler(DdeExitProc, NULL); - - return Tcl_PkgProvide(interp, TCL_DDE_PACKAGE_NAME, TCL_DDE_VERSION); -} - - -/* - *---------------------------------------------------------------------- - * - * Initialize -- - * - * Initialize the global DDE instance. - * - * Results: - * None. - * - * Side effects: - * Registers the DDE server proc. - * - *---------------------------------------------------------------------- - */ - -static void -Initialize(void) -{ - int nameFound = 0; - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - - /* - * See if the application is already registered; if so, remove its - * current name from the registry. The deletion of the command - * will take care of disposing of this entry. - */ - - if (tsdPtr->interpListPtr != NULL) { - nameFound = 1; - } - - /* - * Make sure that the DDE server is there. This is done only once, - * add an exit handler tear it down. - */ - - if (ddeInstance == 0) { - Tcl_MutexLock(&ddeMutex); - if (ddeInstance == 0) { - if (DdeInitialize(&ddeInstance, DdeServerProc, - CBF_SKIP_REGISTRATIONS - | CBF_SKIP_UNREGISTRATIONS - | CBF_FAIL_POKES, 0) - != DMLERR_NO_ERROR) { - ddeInstance = 0; - } - } - Tcl_MutexUnlock(&ddeMutex); - } - if ((ddeServiceGlobal == 0) && (nameFound != 0)) { - Tcl_MutexLock(&ddeMutex); - if ((ddeServiceGlobal == 0) && (nameFound != 0)) { - ddeIsServer = 1; - Tcl_CreateExitHandler(DdeExitProc, NULL); - ddeServiceGlobal = DdeCreateStringHandle(ddeInstance, \ - TCL_DDE_SERVICE_NAME, 0); - DdeNameService(ddeInstance, ddeServiceGlobal, 0L, DNS_REGISTER); - } else { - ddeIsServer = 0; - } - Tcl_MutexUnlock(&ddeMutex); - } -} - -/* - *-------------------------------------------------------------- - * - * DdeSetServerName -- - * - * This procedure is called to associate an ASCII name with a Dde - * server. If the interpreter has already been named, the - * name replaces the old one. - * - * Results: - * The return value is the name actually given to the interp. - * This will normally be the same as name, but if name was already - * in use for a Dde Server then a name of the form "name #2" will - * be chosen, with a high enough number to make the name unique. - * - * Side effects: - * Registration info is saved, thereby allowing the "send" command - * to be used later to invoke commands in the application. In - * addition, the "send" command is created in the application's - * interpreter. The registration will be removed automatically - * if the interpreter is deleted or the "send" command is removed. - * - *-------------------------------------------------------------- - */ - -static char * -DdeSetServerName( - Tcl_Interp *interp, - char *name /* The name that will be used to - * refer to the interpreter in later - * "send" commands. Must be globally - * unique. */ - ) -{ - int suffix, offset; - RegisteredInterp *riPtr, *prevPtr; - Tcl_DString dString; - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - - /* - * See if the application is already registered; if so, remove its - * current name from the registry. The deletion of the command - * will take care of disposing of this entry. - */ - - for (riPtr = tsdPtr->interpListPtr, prevPtr = NULL; riPtr != NULL; - prevPtr = riPtr, riPtr = riPtr->nextPtr) { - if (riPtr->interp == interp) { - if (name != NULL) { - if (prevPtr == NULL) { - tsdPtr->interpListPtr = tsdPtr->interpListPtr->nextPtr; - } else { - prevPtr->nextPtr = riPtr->nextPtr; - } - break; - } else { - /* - * the name was NULL, so the caller is asking for - * the name of the current interp. - */ - - return riPtr->name; - } - } - } - - if (name == NULL) { - /* - * the name was NULL, so the caller is asking for - * the name of the current interp, but it doesn't - * have a name. - */ - - return ""; - } - - /* - * Pick a name to use for the application. Use "name" if it's not - * already in use. Otherwise add a suffix such as " #2", trying - * larger and larger numbers until we eventually find one that is - * unique. - */ - - suffix = 1; - offset = 0; - Tcl_DStringInit(&dString); - - /* - * We have found a unique name. Now add it to the registry. - */ - - riPtr = (RegisteredInterp *) ckalloc(sizeof(RegisteredInterp)); - riPtr->interp = interp; - riPtr->name = ckalloc(strlen(name) + 1); - riPtr->nextPtr = tsdPtr->interpListPtr; - tsdPtr->interpListPtr = riPtr; - strcpy(riPtr->name, name); - - Tcl_CreateObjCommand(interp, "dde", Tcl_DdeObjCmd, - (ClientData) riPtr, DeleteProc); - if (Tcl_IsSafe(interp)) { - Tcl_HideCommand(interp, "dde", "dde"); - } - Tcl_DStringFree(&dString); - - /* - * re-initialize with the new name - */ - Initialize(); - - return riPtr->name; -} - -/* - *-------------------------------------------------------------- - * - * DeleteProc - * - * This procedure is called when the command "dde" is destroyed. - * - * Results: - * none - * - * Side effects: - * The interpreter given by riPtr is unregistered. - * - *-------------------------------------------------------------- - */ - -static void -DeleteProc(clientData) - ClientData clientData; /* The interp we are deleting passed - * as ClientData. */ -{ - RegisteredInterp *riPtr = (RegisteredInterp *) clientData; - RegisteredInterp *searchPtr, *prevPtr; - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - - for (searchPtr = tsdPtr->interpListPtr, prevPtr = NULL; - (searchPtr != NULL) && (searchPtr != riPtr); - prevPtr = searchPtr, searchPtr = searchPtr->nextPtr) { - /* - * Empty loop body. - */ - } - - if (searchPtr != NULL) { - if (prevPtr == NULL) { - tsdPtr->interpListPtr = tsdPtr->interpListPtr->nextPtr; - } else { - prevPtr->nextPtr = searchPtr->nextPtr; - } - } - ckfree(riPtr->name); - Tcl_EventuallyFree(clientData, TCL_DYNAMIC); -} - -/* - *-------------------------------------------------------------- - * - * ExecuteRemoteObject -- - * - * Takes the package delivered by DDE and executes it in - * the server's interpreter. - * - * Results: - * A list Tcl_Obj * that describes what happened. The first - * element is the numerical return code (TCL_ERROR, etc.). - * The second element is the result of the script. If the - * return result was TCL_ERROR, then the third element - * will be the value of the global "errorCode", and the - * fourth will be the value of the global "errorInfo". - * The return result will have a refCount of 0. - * - * Side effects: - * A Tcl script is run, which can cause all kinds of other - * things to happen. - * - *-------------------------------------------------------------- - */ - -static Tcl_Obj * -ExecuteRemoteObject( - RegisteredInterp *riPtr, /* Info about this server. */ - Tcl_Obj *ddeObjectPtr) /* The object to execute. */ -{ - Tcl_Obj *errorObjPtr; - Tcl_Obj *returnPackagePtr; - int result; - - result = Tcl_EvalObjEx(riPtr->interp, ddeObjectPtr, TCL_EVAL_GLOBAL); - returnPackagePtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); - Tcl_ListObjAppendElement(NULL, returnPackagePtr, - Tcl_NewIntObj(result)); - Tcl_ListObjAppendElement(NULL, returnPackagePtr, - Tcl_GetObjResult(riPtr->interp)); - if (result == TCL_ERROR) { - errorObjPtr = Tcl_GetVar2Ex(riPtr->interp, "errorCode", NULL, - TCL_GLOBAL_ONLY); - Tcl_ListObjAppendElement(NULL, returnPackagePtr, errorObjPtr); - errorObjPtr = Tcl_GetVar2Ex(riPtr->interp, "errorInfo", NULL, - TCL_GLOBAL_ONLY); - Tcl_ListObjAppendElement(NULL, returnPackagePtr, errorObjPtr); - } - - return returnPackagePtr; -} - -/* - *-------------------------------------------------------------- - * - * DdeServerProc -- - * - * Handles all transactions for this server. Can handle - * execute, request, and connect protocols. Dde will - * call this routine when a client attempts to run a dde - * command using this server. - * - * Results: - * A DDE Handle with the result of the dde command. - * - * Side effects: - * Depending on which command is executed, arbitrary - * Tcl scripts can be run. - * - *-------------------------------------------------------------- - */ - -static HDDEDATA CALLBACK -DdeServerProc ( - UINT uType, /* The type of DDE transaction we - * are performing. */ - UINT uFmt, /* The format that data is sent or - * received. */ - HCONV hConv, /* The conversation associated with the - * current transaction. */ - HSZ ddeTopic, /* A string handle. Transaction-type - * dependent. */ - HSZ ddeItem, /* A string handle. Transaction-type - * dependent. */ - HDDEDATA hData, /* DDE data. Transaction-type dependent. */ - DWORD dwData1, /* Transaction-dependent data. */ - DWORD dwData2) /* Transaction-dependent data. */ -{ - Tcl_DString dString; - int len; - char *utilString; - Tcl_Obj *ddeObjectPtr; - HDDEDATA ddeReturn = NULL; - RegisteredInterp *riPtr; - Conversation *convPtr, *prevConvPtr; - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - - switch(uType) { - case XTYP_CONNECT: - - /* - * Dde is trying to initialize a conversation with us. Check - * and make sure we have a valid topic. - */ - - len = DdeQueryString(ddeInstance, ddeTopic, NULL, 0, 0); - Tcl_DStringInit(&dString); - Tcl_DStringSetLength(&dString, len); - utilString = Tcl_DStringValue(&dString); - DdeQueryString(ddeInstance, ddeTopic, utilString, len + 1, - CP_WINANSI); - - for (riPtr = tsdPtr->interpListPtr; riPtr != NULL; - riPtr = riPtr->nextPtr) { - if (stricmp(utilString, riPtr->name) == 0) { - Tcl_DStringFree(&dString); - return (HDDEDATA) TRUE; - } - } - - Tcl_DStringFree(&dString); - return (HDDEDATA) FALSE; - - case XTYP_CONNECT_CONFIRM: - - /* - * Dde has decided that we can connect, so it gives us a - * conversation handle. We need to keep track of it - * so we know which execution result to return in an - * XTYP_REQUEST. - */ - - len = DdeQueryString(ddeInstance, ddeTopic, NULL, 0, 0); - Tcl_DStringInit(&dString); - Tcl_DStringSetLength(&dString, len); - utilString = Tcl_DStringValue(&dString); - DdeQueryString(ddeInstance, ddeTopic, utilString, len + 1, - CP_WINANSI); - for (riPtr = tsdPtr->interpListPtr; riPtr != NULL; - riPtr = riPtr->nextPtr) { - if (stricmp(riPtr->name, utilString) == 0) { - convPtr = (Conversation *) ckalloc(sizeof(Conversation)); - convPtr->nextPtr = tsdPtr->currentConversations; - convPtr->returnPackagePtr = NULL; - convPtr->hConv = hConv; - convPtr->riPtr = riPtr; - tsdPtr->currentConversations = convPtr; - break; - } - } - Tcl_DStringFree(&dString); - return (HDDEDATA) TRUE; - - case XTYP_DISCONNECT: - - /* - * The client has disconnected from our server. Forget this - * conversation. - */ - - for (convPtr = tsdPtr->currentConversations, prevConvPtr = NULL; - convPtr != NULL; - prevConvPtr = convPtr, convPtr = convPtr->nextPtr) { - if (hConv == convPtr->hConv) { - if (prevConvPtr == NULL) { - tsdPtr->currentConversations = convPtr->nextPtr; - } else { - prevConvPtr->nextPtr = convPtr->nextPtr; - } - if (convPtr->returnPackagePtr != NULL) { - Tcl_DecrRefCount(convPtr->returnPackagePtr); - } - ckfree((char *) convPtr); - break; - } - } - return (HDDEDATA) TRUE; - - case XTYP_REQUEST: - - /* - * This could be either a request for a value of a Tcl variable, - * or it could be the send command requesting the results of the - * last execute. - */ - - if (uFmt != CF_TEXT) { - return (HDDEDATA) FALSE; - } - - ddeReturn = (HDDEDATA) FALSE; - for (convPtr = tsdPtr->currentConversations; (convPtr != NULL) - && (convPtr->hConv != hConv); convPtr = convPtr->nextPtr) { - /* - * Empty loop body. - */ - } - - if (convPtr != NULL) { - char *returnString; - - len = DdeQueryString(ddeInstance, ddeItem, NULL, 0, - CP_WINANSI); - Tcl_DStringInit(&dString); - Tcl_DStringSetLength(&dString, len); - utilString = Tcl_DStringValue(&dString); - DdeQueryString(ddeInstance, ddeItem, utilString, - len + 1, CP_WINANSI); - if (stricmp(utilString, "$TCLEVAL$EXECUTE$RESULT") == 0) { - returnString = - Tcl_GetStringFromObj(convPtr->returnPackagePtr, &len); - ddeReturn = DdeCreateDataHandle(ddeInstance, - returnString, len+1, 0, ddeItem, CF_TEXT, - 0); - } else { - Tcl_Obj *variableObjPtr = Tcl_GetVar2Ex( - convPtr->riPtr->interp, utilString, NULL, - TCL_GLOBAL_ONLY); - if (variableObjPtr != NULL) { - returnString = Tcl_GetStringFromObj(variableObjPtr, - &len); - ddeReturn = DdeCreateDataHandle(ddeInstance, - returnString, len+1, 0, ddeItem, CF_TEXT, 0); - } else { - ddeReturn = NULL; - } - } - Tcl_DStringFree(&dString); - } - return ddeReturn; - - case XTYP_EXECUTE: { - - /* - * Execute this script. The results will be saved into - * a list object which will be retreived later. See - * ExecuteRemoteObject. - */ - - Tcl_Obj *returnPackagePtr; - - for (convPtr = tsdPtr->currentConversations; (convPtr != NULL) - && (convPtr->hConv != hConv); convPtr = convPtr->nextPtr) { - /* - * Empty loop body. - */ - - } - - if (convPtr == NULL) { - return (HDDEDATA) DDE_FNOTPROCESSED; - } - - utilString = (char *) DdeAccessData(hData, &len); - ddeObjectPtr = Tcl_NewStringObj(utilString, -1); - Tcl_IncrRefCount(ddeObjectPtr); - DdeUnaccessData(hData); - if (convPtr->returnPackagePtr != NULL) { - Tcl_DecrRefCount(convPtr->returnPackagePtr); - } - convPtr->returnPackagePtr = NULL; - returnPackagePtr = - ExecuteRemoteObject(convPtr->riPtr, ddeObjectPtr); - for (convPtr = tsdPtr->currentConversations; (convPtr != NULL) - && (convPtr->hConv != hConv); convPtr = convPtr->nextPtr) { - /* - * Empty loop body. - */ - - } - if (convPtr != NULL) { - Tcl_IncrRefCount(returnPackagePtr); - convPtr->returnPackagePtr = returnPackagePtr; - } - Tcl_DecrRefCount(ddeObjectPtr); - if (returnPackagePtr == NULL) { - return (HDDEDATA) DDE_FNOTPROCESSED; - } else { - return (HDDEDATA) DDE_FACK; - } - } - - case XTYP_WILDCONNECT: { - - /* - * Dde wants a list of services and topics that we support. - */ - - HSZPAIR *returnPtr; - int i; - int numItems; - - for (i = 0, riPtr = tsdPtr->interpListPtr; riPtr != NULL; - i++, riPtr = riPtr->nextPtr) { - /* - * Empty loop body. - */ - - } - - numItems = i; - ddeReturn = DdeCreateDataHandle(ddeInstance, NULL, - (numItems + 1) * sizeof(HSZPAIR), 0, 0, 0, 0); - returnPtr = (HSZPAIR *) DdeAccessData(ddeReturn, &len); - for (i = 0, riPtr = tsdPtr->interpListPtr; i < numItems; - i++, riPtr = riPtr->nextPtr) { - returnPtr[i].hszSvc = DdeCreateStringHandle( - ddeInstance, "TclEval", CP_WINANSI); - returnPtr[i].hszTopic = DdeCreateStringHandle( - ddeInstance, riPtr->name, CP_WINANSI); - } - returnPtr[i].hszSvc = NULL; - returnPtr[i].hszTopic = NULL; - DdeUnaccessData(ddeReturn); - return ddeReturn; - } - - } - return NULL; -} - -/* - *-------------------------------------------------------------- - * - * DdeExitProc -- - * - * Gets rid of our DDE server when we go away. - * - * Results: - * None. - * - * Side effects: - * The DDE server is deleted. - * - *-------------------------------------------------------------- - */ - -static void -DdeExitProc( - ClientData clientData) /* Not used in this handler. */ -{ - DdeNameService(ddeInstance, NULL, 0, DNS_UNREGISTER); - DdeUninitialize(ddeInstance); - ddeInstance = 0; -} - -/* - *-------------------------------------------------------------- - * - * MakeDdeConnection -- - * - * This procedure is a utility used to connect to a DDE - * server when given a server name and a topic name. - * - * Results: - * A standard Tcl result. - * - * - * Side effects: - * Passes back a conversation through ddeConvPtr - * - *-------------------------------------------------------------- - */ - -static int -MakeDdeConnection( - Tcl_Interp *interp, /* Used to report errors. */ - char *name, /* The connection to use. */ - HCONV *ddeConvPtr) -{ - HSZ ddeTopic, ddeService; - HCONV ddeConv; - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - - ddeService = DdeCreateStringHandle(ddeInstance, "TclEval", 0); - ddeTopic = DdeCreateStringHandle(ddeInstance, name, 0); - - ddeConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL); - DdeFreeStringHandle(ddeInstance, ddeService); - DdeFreeStringHandle(ddeInstance, ddeTopic); - - if (ddeConv == (HCONV) NULL) { - if (interp != NULL) { - Tcl_AppendResult(interp, "no registered server named \"", - name, "\"", (char *) NULL); - } - return TCL_ERROR; - } - - *ddeConvPtr = ddeConv; - return TCL_OK; -} - -/* - *-------------------------------------------------------------- - * - * SetDdeError -- - * - * Sets the interp result to a cogent error message - * describing the last DDE error. - * - * Results: - * None. - * - * - * Side effects: - * The interp's result object is changed. - * - *-------------------------------------------------------------- - */ - -static void -SetDdeError( - Tcl_Interp *interp) /* The interp to put the message in.*/ -{ - Tcl_Obj *resultPtr = Tcl_GetObjResult(interp); - int err; - - err = DdeGetLastError(ddeInstance); - switch (err) { - case DMLERR_DATAACKTIMEOUT: - case DMLERR_EXECACKTIMEOUT: - case DMLERR_POKEACKTIMEOUT: - Tcl_SetStringObj(resultPtr, - "remote interpreter did not respond", -1); - break; - - case DMLERR_BUSY: - Tcl_SetStringObj(resultPtr, "remote server is busy", -1); - break; - - case DMLERR_NOTPROCESSED: - Tcl_SetStringObj(resultPtr, - "remote server cannot handle this command", -1); - break; - - default: - Tcl_SetStringObj(resultPtr, "dde command failed", -1); - } -} - -/* - *-------------------------------------------------------------- - * - * Tcl_DdeObjCmd -- - * - * This procedure is invoked to process the "dde" Tcl command. - * See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *-------------------------------------------------------------- - */ - -int -Tcl_DdeObjCmd( - ClientData clientData, /* Used only for deletion */ - Tcl_Interp *interp, /* The interp we are sending from */ - int objc, /* Number of arguments */ - Tcl_Obj *CONST objv[]) /* The arguments */ -{ - enum { - DDE_SERVERNAME, - DDE_EXECUTE, - DDE_POKE, - DDE_REQUEST, - DDE_SERVICES, - DDE_EVAL - }; - - static char *ddeCommands[] = {"servername", "execute", "poke", - "request", "services", "eval", - (char *) NULL}; - static char *ddeOptions[] = {"-async", (char *) NULL}; - int index, argIndex; - int async = 0; - int result = TCL_OK; - HSZ ddeService = NULL; - HSZ ddeTopic = NULL; - HSZ ddeItem = NULL; - HDDEDATA ddeData = NULL; - HDDEDATA ddeItemData = NULL; - HCONV hConv = NULL; - HSZ ddeCookie = 0; - char *serviceName, *topicName, *itemString, *dataString; - char *string; - int firstArg, length, dataLength; - DWORD ddeResult; - HDDEDATA ddeReturn; - RegisteredInterp *riPtr; - Tcl_Interp *sendInterp; - Tcl_Obj *objPtr; - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - - /* - * Initialize DDE server/client - */ - - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, - "?-async? serviceName topicName value"); - return TCL_ERROR; - } - - if (Tcl_GetIndexFromObj(interp, objv[1], ddeCommands, "command", 0, - &index) != TCL_OK) { - return TCL_ERROR; - } - - switch (index) { - case DDE_SERVERNAME: - if ((objc != 3) && (objc != 2)) { - Tcl_WrongNumArgs(interp, 1, objv, - "servername ?serverName?"); - return TCL_ERROR; - } - firstArg = (objc - 1); - break; - case DDE_EXECUTE: - if ((objc < 5) || (objc > 6)) { - Tcl_WrongNumArgs(interp, 1, objv, - "execute ?-async? serviceName topicName value"); - return TCL_ERROR; - } - if (Tcl_GetIndexFromObj(NULL, objv[2], ddeOptions, "option", 0, - &argIndex) != TCL_OK) { - if (objc != 5) { - Tcl_WrongNumArgs(interp, 1, objv, - "execute ?-async? serviceName topicName value"); - return TCL_ERROR; - } - async = 0; - firstArg = 2; - } else { - if (objc != 6) { - Tcl_WrongNumArgs(interp, 1, objv, - "execute ?-async? serviceName topicName value"); - return TCL_ERROR; - } - async = 1; - firstArg = 3; - } - break; - case DDE_POKE: - if (objc != 6) { - Tcl_WrongNumArgs(interp, 1, objv, - "poke serviceName topicName item value"); - return TCL_ERROR; - } - firstArg = 2; - break; - case DDE_REQUEST: - if (objc != 5) { - Tcl_WrongNumArgs(interp, 1, objv, - "request serviceName topicName value"); - return TCL_ERROR; - } - firstArg = 2; - break; - case DDE_SERVICES: - if (objc != 4) { - Tcl_WrongNumArgs(interp, 1, objv, - "services serviceName topicName"); - return TCL_ERROR; - } - firstArg = 2; - break; - case DDE_EVAL: - if (objc < 4) { - Tcl_WrongNumArgs(interp, 1, objv, - "eval ?-async? serviceName args"); - return TCL_ERROR; - } - if (Tcl_GetIndexFromObj(NULL, objv[2], ddeOptions, "option", 0, - &argIndex) != TCL_OK) { - if (objc < 4) { - Tcl_WrongNumArgs(interp, 1, objv, - "eval ?-async? serviceName args"); - return TCL_ERROR; - } - async = 0; - firstArg = 2; - } else { - if (objc < 5) { - Tcl_WrongNumArgs(interp, 1, objv, - "eval ?-async? serviceName args"); - return TCL_ERROR; - } - async = 1; - firstArg = 3; - } - break; - } - - Initialize(); - - if (firstArg != 1) { - serviceName = Tcl_GetStringFromObj(objv[firstArg], &length); - } else { - length = 0; - } - - if (length == 0) { - serviceName = NULL; - } else if ((index != DDE_SERVERNAME) && (index != DDE_EVAL)) { - ddeService = DdeCreateStringHandle(ddeInstance, serviceName, - CP_WINANSI); - } - - if ((index != DDE_SERVERNAME) &&(index != DDE_EVAL)) { - topicName = Tcl_GetStringFromObj(objv[firstArg + 1], &length); - if (length == 0) { - topicName = NULL; - } else { - ddeTopic = DdeCreateStringHandle(ddeInstance, - topicName, CP_WINANSI); - } - } - - switch (index) { - case DDE_SERVERNAME: { - serviceName = DdeSetServerName(interp, serviceName); - if (serviceName != NULL) { - Tcl_SetStringObj(Tcl_GetObjResult(interp), - serviceName, -1); - } else { - Tcl_ResetResult(interp); - } - break; - } - case DDE_EXECUTE: { - dataString = Tcl_GetStringFromObj(objv[firstArg + 2], &dataLength); - if (dataLength == 0) { - Tcl_SetStringObj(Tcl_GetObjResult(interp), - "cannot execute null data", -1); - result = TCL_ERROR; - break; - } - hConv = DdeConnect(ddeInstance, ddeService, ddeTopic, - NULL); - DdeFreeStringHandle (ddeInstance, ddeService) ; - DdeFreeStringHandle (ddeInstance, ddeTopic) ; - - if (hConv == NULL) { - SetDdeError(interp); - result = TCL_ERROR; - break; - } - - ddeData = DdeCreateDataHandle(ddeInstance, dataString, - dataLength+1, 0, 0, CF_TEXT, 0); - if (ddeData != NULL) { - if (async) { - DdeClientTransaction((LPBYTE) ddeData, 0xFFFFFFFF, hConv, 0, - CF_TEXT, XTYP_EXECUTE, TIMEOUT_ASYNC, &ddeResult); - DdeAbandonTransaction(ddeInstance, hConv, - ddeResult); - } else { - ddeReturn = DdeClientTransaction((LPBYTE) ddeData, 0xFFFFFFFF, - hConv, 0, CF_TEXT, XTYP_EXECUTE, 30000, NULL); - if (ddeReturn == 0) { - SetDdeError(interp); - result = TCL_ERROR; - } - } - DdeFreeDataHandle(ddeData); - } else { - SetDdeError(interp); - result = TCL_ERROR; - } - break; - } - case DDE_REQUEST: { - itemString = Tcl_GetStringFromObj(objv[firstArg + 2], &length); - if (length == 0) { - Tcl_SetStringObj(Tcl_GetObjResult(interp), - "cannot request value of null data", -1); - return TCL_ERROR; - } - hConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL); - DdeFreeStringHandle (ddeInstance, ddeService) ; - DdeFreeStringHandle (ddeInstance, ddeTopic) ; - - if (hConv == NULL) { - SetDdeError(interp); - result = TCL_ERROR; - } else { - Tcl_Obj *returnObjPtr; - ddeItem = DdeCreateStringHandle(ddeInstance, - itemString, CP_WINANSI); - if (ddeItem != NULL) { - ddeData = DdeClientTransaction(NULL, 0, hConv, ddeItem, - CF_TEXT, XTYP_REQUEST, 5000, NULL); - if (ddeData == NULL) { - SetDdeError(interp); - result = TCL_ERROR; - } else { - dataString = DdeAccessData(ddeData, &dataLength); - returnObjPtr = Tcl_NewStringObj(dataString, -1); - DdeUnaccessData(ddeData); - DdeFreeDataHandle(ddeData); - Tcl_SetObjResult(interp, returnObjPtr); - } - } else { - SetDdeError(interp); - result = TCL_ERROR; - } - } - - break; - } - case DDE_POKE: { - itemString = Tcl_GetStringFromObj(objv[firstArg + 2], &length); - if (length == 0) { - Tcl_SetStringObj(Tcl_GetObjResult(interp), - "cannot have a null item", -1); - return TCL_ERROR; - } - dataString = Tcl_GetStringFromObj(objv[firstArg + 3], &length); - - hConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL); - DdeFreeStringHandle (ddeInstance,ddeService) ; - DdeFreeStringHandle (ddeInstance, ddeTopic) ; - - if (hConv == NULL) { - SetDdeError(interp); - result = TCL_ERROR; - } else { - ddeItem = DdeCreateStringHandle(ddeInstance, itemString, \ - CP_WINANSI); - if (ddeItem != NULL) { - ddeData = DdeClientTransaction(dataString,length+1, \ - hConv, ddeItem, - CF_TEXT, XTYP_POKE, 5000, NULL); - if (ddeData == NULL) { - SetDdeError(interp); - result = TCL_ERROR; - } - } else { - SetDdeError(interp); - result = TCL_ERROR; - } - } - break; - } - - case DDE_SERVICES: { - HCONVLIST hConvList; - CONVINFO convInfo; - Tcl_Obj *convListObjPtr, *elementObjPtr; - Tcl_DString dString; - char *name; - - convInfo.cb = sizeof(CONVINFO); - hConvList = DdeConnectList(ddeInstance, ddeService, - ddeTopic, 0, NULL); - DdeFreeStringHandle (ddeInstance,ddeService) ; - DdeFreeStringHandle (ddeInstance, ddeTopic) ; - hConv = 0; - convListObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); - Tcl_DStringInit(&dString); - - while (hConv = DdeQueryNextServer(hConvList, hConv), hConv != 0) { - elementObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); - DdeQueryConvInfo(hConv, QID_SYNC, &convInfo); - length = DdeQueryString(ddeInstance, - convInfo.hszSvcPartner, NULL, 0, CP_WINANSI); - Tcl_DStringSetLength(&dString, length); - name = Tcl_DStringValue(&dString); - DdeQueryString(ddeInstance, convInfo.hszSvcPartner, - name, length + 1, CP_WINANSI); - Tcl_ListObjAppendElement(interp, elementObjPtr, - Tcl_NewStringObj(name, length)); - length = DdeQueryString(ddeInstance, convInfo.hszTopic, - NULL, 0, CP_WINANSI); - Tcl_DStringSetLength(&dString, length); - name = Tcl_DStringValue(&dString); - DdeQueryString(ddeInstance, convInfo.hszTopic, name, - length + 1, CP_WINANSI); - Tcl_ListObjAppendElement(interp, elementObjPtr, - Tcl_NewStringObj(name, length)); - Tcl_ListObjAppendElement(interp, convListObjPtr, elementObjPtr); - } - DdeDisconnectList(hConvList); - Tcl_SetObjResult(interp, convListObjPtr); - Tcl_DStringFree(&dString); - break; - } - case DDE_EVAL: { - objc -= (async + 3); - ((Tcl_Obj **) objv) += (async + 3); - - /* - * See if the target interpreter is local. If so, execute - * the command directly without going through the DDE server. - * Don't exchange objects between interps. The target interp could - * compile an object, producing a bytecode structure that refers to - * other objects owned by the target interp. If the target interp - * is then deleted, the bytecode structure would be referring to - * deallocated objects. - */ - - for (riPtr = tsdPtr->interpListPtr; riPtr != NULL; riPtr - = riPtr->nextPtr) { - if (stricmp(serviceName, riPtr->name) == 0) { - break; - } - } - - if (riPtr != NULL) { - /* - * This command is to a local interp. No need to go through - * the server. - */ - - Tcl_Preserve((ClientData) riPtr); - sendInterp = riPtr->interp; - Tcl_Preserve((ClientData) sendInterp); - - /* - * Don't exchange objects between interps. The target interp would - * compile an object, producing a bytecode structure that refers to - * other objects owned by the target interp. If the target interp - * is then deleted, the bytecode structure would be referring to - * deallocated objects. - */ - - if (objc == 1) { - result = Tcl_EvalObjEx(sendInterp, objv[0], TCL_EVAL_GLOBAL); - } else { - objPtr = Tcl_ConcatObj(objc, objv); - Tcl_IncrRefCount(objPtr); - result = Tcl_EvalObjEx(sendInterp, objPtr, TCL_EVAL_GLOBAL); - Tcl_DecrRefCount(objPtr); - } - if (interp != sendInterp) { - if (result == TCL_ERROR) { - /* - * An error occurred, so transfer error information from the - * destination interpreter back to our interpreter. - */ - - Tcl_ResetResult(interp); - objPtr = Tcl_GetVar2Ex(sendInterp, "errorInfo", NULL, - TCL_GLOBAL_ONLY); - string = Tcl_GetStringFromObj(objPtr, &length); - Tcl_AddObjErrorInfo(interp, string, length); - - objPtr = Tcl_GetVar2Ex(sendInterp, "errorCode", NULL, - TCL_GLOBAL_ONLY); - Tcl_SetObjErrorCode(interp, objPtr); - } - Tcl_SetObjResult(interp, Tcl_GetObjResult(sendInterp)); - } - Tcl_Release((ClientData) riPtr); - Tcl_Release((ClientData) sendInterp); - } else { - /* - * This is a non-local request. Send the script to the server and poll - * it for a result. - */ - - if (MakeDdeConnection(interp, serviceName, &hConv) != TCL_OK) { - goto error; - } - - objPtr = Tcl_ConcatObj(objc, objv); - string = Tcl_GetStringFromObj(objPtr, &length); - ddeItemData = DdeCreateDataHandle(ddeInstance, string, length+1, 0, 0, - CF_TEXT, 0); - - if (async) { - ddeData = DdeClientTransaction((LPBYTE) ddeItemData, 0xFFFFFFFF, hConv, 0, - CF_TEXT, XTYP_EXECUTE, TIMEOUT_ASYNC, &ddeResult); - DdeAbandonTransaction(ddeInstance, hConv, ddeResult); - } else { - ddeData = DdeClientTransaction((LPBYTE) ddeItemData, 0xFFFFFFFF, hConv, 0, - CF_TEXT, XTYP_EXECUTE, 30000, NULL); - if (ddeData != 0) { - - ddeCookie = DdeCreateStringHandle(ddeInstance, - "$TCLEVAL$EXECUTE$RESULT", CP_WINANSI); - ddeData = DdeClientTransaction(NULL, 0, hConv, ddeCookie, - CF_TEXT, XTYP_REQUEST, 30000, NULL); - } - } - - - Tcl_DecrRefCount(objPtr); - - if (ddeData == 0) { - SetDdeError(interp); - goto errorNoResult; - } - - if (async == 0) { - Tcl_Obj *resultPtr; - - /* - * The return handle has a two or four element list in it. The first - * element is the return code (TCL_OK, TCL_ERROR, etc.). The - * second is the result of the script. If the return code is TCL_ERROR, - * then the third element is the value of the variable "errorCode", - * and the fourth is the value of the variable "errorInfo". - */ - - resultPtr = Tcl_NewObj(); - length = DdeGetData(ddeData, NULL, 0, 0); - Tcl_SetObjLength(resultPtr, length); - string = Tcl_GetString(resultPtr); - DdeGetData(ddeData, string, length, 0); - Tcl_SetObjLength(resultPtr, strlen(string)); - - if (Tcl_ListObjIndex(NULL, resultPtr, 0, &objPtr) != TCL_OK) { - Tcl_DecrRefCount(resultPtr); - goto error; - } - if (Tcl_GetIntFromObj(NULL, objPtr, &result) != TCL_OK) { - Tcl_DecrRefCount(resultPtr); - goto error; - } - if (result == TCL_ERROR) { - Tcl_ResetResult(interp); - - if (Tcl_ListObjIndex(NULL, resultPtr, 3, &objPtr) != TCL_OK) { - Tcl_DecrRefCount(resultPtr); - goto error; - } - length = -1; - string = Tcl_GetStringFromObj(objPtr, &length); - Tcl_AddObjErrorInfo(interp, string, length); - - Tcl_ListObjIndex(NULL, resultPtr, 2, &objPtr); - Tcl_SetObjErrorCode(interp, objPtr); - } - if (Tcl_ListObjIndex(NULL, resultPtr, 1, &objPtr) != TCL_OK) { - Tcl_DecrRefCount(resultPtr); - goto error; - } - Tcl_SetObjResult(interp, objPtr); - Tcl_DecrRefCount(resultPtr); - } - } - } - } - if (ddeCookie != NULL) { - DdeFreeStringHandle(ddeInstance, ddeCookie); - } - if (ddeItem != NULL) { - DdeFreeStringHandle(ddeInstance, ddeItem); - } - if (ddeItemData != NULL) { - DdeFreeDataHandle(ddeItemData); - } - if (ddeData != NULL) { - DdeFreeDataHandle(ddeData); - } - if (hConv != NULL) { - DdeDisconnect(hConv); - } - return result; - - error: - Tcl_SetStringObj(Tcl_GetObjResult(interp), - "invalid data returned from server", -1); - - errorNoResult: - if (ddeCookie != NULL) { - DdeFreeStringHandle(ddeInstance, ddeCookie); - } - if (ddeItem != NULL) { - DdeFreeStringHandle(ddeInstance, ddeItem); - } - if (ddeItemData != NULL) { - DdeFreeDataHandle(ddeItemData); - } - if (ddeData != NULL) { - DdeFreeDataHandle(ddeData); - } - if (hConv != NULL) { - DdeDisconnect(hConv); - } - return TCL_ERROR; -} diff --git a/win/tclWinError.c b/win/tclWinError.c deleted file mode 100644 index 7786334..0000000 --- a/win/tclWinError.c +++ /dev/null @@ -1,392 +0,0 @@ -/* - * tclWinError.c -- - * - * This file contains code for converting from Win32 errors to - * errno errors. - * - * Copyright (c) 1995-1996 by Sun Microsystems, Inc. - * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclWinError.c,v 1.3 1999/04/16 00:48:08 stanton Exp $ - */ - -#include "tclWinInt.h" - -/* - * The following table contains the mapping from Win32 errors to - * errno errors. - */ - -static char errorTable[] = { - 0, - EINVAL, /* ERROR_INVALID_FUNCTION 1 */ - ENOENT, /* ERROR_FILE_NOT_FOUND 2 */ - ENOENT, /* ERROR_PATH_NOT_FOUND 3 */ - EMFILE, /* ERROR_TOO_MANY_OPEN_FILES 4 */ - EACCES, /* ERROR_ACCESS_DENIED 5 */ - EBADF, /* ERROR_INVALID_HANDLE 6 */ - ENOMEM, /* ERROR_ARENA_TRASHED 7 */ - ENOMEM, /* ERROR_NOT_ENOUGH_MEMORY 8 */ - ENOMEM, /* ERROR_INVALID_BLOCK 9 */ - E2BIG, /* ERROR_BAD_ENVIRONMENT 10 */ - ENOEXEC, /* ERROR_BAD_FORMAT 11 */ - EACCES, /* ERROR_INVALID_ACCESS 12 */ - EINVAL, /* ERROR_INVALID_DATA 13 */ - EFAULT, /* ERROR_OUT_OF_MEMORY 14 */ - ENOENT, /* ERROR_INVALID_DRIVE 15 */ - EACCES, /* ERROR_CURRENT_DIRECTORY 16 */ - EXDEV, /* ERROR_NOT_SAME_DEVICE 17 */ - ENOENT, /* ERROR_NO_MORE_FILES 18 */ - EROFS, /* ERROR_WRITE_PROTECT 19 */ - ENXIO, /* ERROR_BAD_UNIT 20 */ - EBUSY, /* ERROR_NOT_READY 21 */ - EIO, /* ERROR_BAD_COMMAND 22 */ - EIO, /* ERROR_CRC 23 */ - EIO, /* ERROR_BAD_LENGTH 24 */ - EIO, /* ERROR_SEEK 25 */ - EIO, /* ERROR_NOT_DOS_DISK 26 */ - ENXIO, /* ERROR_SECTOR_NOT_FOUND 27 */ - EBUSY, /* ERROR_OUT_OF_PAPER 28 */ - EIO, /* ERROR_WRITE_FAULT 29 */ - EIO, /* ERROR_READ_FAULT 30 */ - EIO, /* ERROR_GEN_FAILURE 31 */ - EACCES, /* ERROR_SHARING_VIOLATION 32 */ - EACCES, /* ERROR_LOCK_VIOLATION 33 */ - ENXIO, /* ERROR_WRONG_DISK 34 */ - ENFILE, /* ERROR_FCB_UNAVAILABLE 35 */ - ENFILE, /* ERROR_SHARING_BUFFER_EXCEEDED 36 */ - EINVAL, /* 37 */ - EINVAL, /* 38 */ - ENOSPC, /* ERROR_HANDLE_DISK_FULL 39 */ - EINVAL, /* 40 */ - EINVAL, /* 41 */ - EINVAL, /* 42 */ - EINVAL, /* 43 */ - EINVAL, /* 44 */ - EINVAL, /* 45 */ - EINVAL, /* 46 */ - EINVAL, /* 47 */ - EINVAL, /* 48 */ - EINVAL, /* 49 */ - ENODEV, /* ERROR_NOT_SUPPORTED 50 */ - EBUSY, /* ERROR_REM_NOT_LIST 51 */ - EEXIST, /* ERROR_DUP_NAME 52 */ - ENOENT, /* ERROR_BAD_NETPATH 53 */ - EBUSY, /* ERROR_NETWORK_BUSY 54 */ - ENODEV, /* ERROR_DEV_NOT_EXIST 55 */ - EAGAIN, /* ERROR_TOO_MANY_CMDS 56 */ - EIO, /* ERROR_ADAP_HDW_ERR 57 */ - EIO, /* ERROR_BAD_NET_RESP 58 */ - EIO, /* ERROR_UNEXP_NET_ERR 59 */ - EINVAL, /* ERROR_BAD_REM_ADAP 60 */ - EFBIG, /* ERROR_PRINTQ_FULL 61 */ - ENOSPC, /* ERROR_NO_SPOOL_SPACE 62 */ - ENOENT, /* ERROR_PRINT_CANCELLED 63 */ - ENOENT, /* ERROR_NETNAME_DELETED 64 */ - EACCES, /* ERROR_NETWORK_ACCESS_DENIED 65 */ - ENODEV, /* ERROR_BAD_DEV_TYPE 66 */ - ENOENT, /* ERROR_BAD_NET_NAME 67 */ - ENFILE, /* ERROR_TOO_MANY_NAMES 68 */ - EIO, /* ERROR_TOO_MANY_SESS 69 */ - EAGAIN, /* ERROR_SHARING_PAUSED 70 */ - EINVAL, /* ERROR_REQ_NOT_ACCEP 71 */ - EAGAIN, /* ERROR_REDIR_PAUSED 72 */ - EINVAL, /* 73 */ - EINVAL, /* 74 */ - EINVAL, /* 75 */ - EINVAL, /* 76 */ - EINVAL, /* 77 */ - EINVAL, /* 78 */ - EINVAL, /* 79 */ - EEXIST, /* ERROR_FILE_EXISTS 80 */ - EINVAL, /* 81 */ - ENOSPC, /* ERROR_CANNOT_MAKE 82 */ - EIO, /* ERROR_FAIL_I24 83 */ - ENFILE, /* ERROR_OUT_OF_STRUCTURES 84 */ - EEXIST, /* ERROR_ALREADY_ASSIGNED 85 */ - EPERM, /* ERROR_INVALID_PASSWORD 86 */ - EINVAL, /* ERROR_INVALID_PARAMETER 87 */ - EIO, /* ERROR_NET_WRITE_FAULT 88 */ - EAGAIN, /* ERROR_NO_PROC_SLOTS 89 */ - EINVAL, /* 90 */ - EINVAL, /* 91 */ - EINVAL, /* 92 */ - EINVAL, /* 93 */ - EINVAL, /* 94 */ - EINVAL, /* 95 */ - EINVAL, /* 96 */ - EINVAL, /* 97 */ - EINVAL, /* 98 */ - EINVAL, /* 99 */ - EINVAL, /* 100 */ - EINVAL, /* 101 */ - EINVAL, /* 102 */ - EINVAL, /* 103 */ - EINVAL, /* 104 */ - EINVAL, /* 105 */ - EINVAL, /* 106 */ - EXDEV, /* ERROR_DISK_CHANGE 107 */ - EAGAIN, /* ERROR_DRIVE_LOCKED 108 */ - EPIPE, /* ERROR_BROKEN_PIPE 109 */ - ENOENT, /* ERROR_OPEN_FAILED 110 */ - EINVAL, /* ERROR_BUFFER_OVERFLOW 111 */ - ENOSPC, /* ERROR_DISK_FULL 112 */ - EMFILE, /* ERROR_NO_MORE_SEARCH_HANDLES 113 */ - EBADF, /* ERROR_INVALID_TARGET_HANDLE 114 */ - EFAULT, /* ERROR_PROTECTION_VIOLATION 115 */ - EINVAL, /* 116 */ - EINVAL, /* 117 */ - EINVAL, /* 118 */ - EINVAL, /* 119 */ - EINVAL, /* 120 */ - EINVAL, /* 121 */ - EINVAL, /* 122 */ - ENOENT, /* ERROR_INVALID_NAME 123 */ - EINVAL, /* 124 */ - EINVAL, /* 125 */ - EINVAL, /* 126 */ - ESRCH, /* ERROR_PROC_NOT_FOUND 127 */ - ECHILD, /* ERROR_WAIT_NO_CHILDREN 128 */ - ECHILD, /* ERROR_CHILD_NOT_COMPLETE 129 */ - EBADF, /* ERROR_DIRECT_ACCESS_HANDLE 130 */ - EINVAL, /* 131 */ - ESPIPE, /* ERROR_SEEK_ON_DEVICE 132 */ - EINVAL, /* 133 */ - EINVAL, /* 134 */ - EINVAL, /* 135 */ - EINVAL, /* 136 */ - EINVAL, /* 137 */ - EINVAL, /* 138 */ - EINVAL, /* 139 */ - EINVAL, /* 140 */ - EINVAL, /* 141 */ - EAGAIN, /* ERROR_BUSY_DRIVE 142 */ - EINVAL, /* 143 */ - EINVAL, /* 144 */ - EEXIST, /* ERROR_DIR_NOT_EMPTY 145 */ - EINVAL, /* 146 */ - EINVAL, /* 147 */ - EINVAL, /* 148 */ - EINVAL, /* 149 */ - EINVAL, /* 150 */ - EINVAL, /* 151 */ - EINVAL, /* 152 */ - EINVAL, /* 153 */ - EINVAL, /* 154 */ - EINVAL, /* 155 */ - EINVAL, /* 156 */ - EINVAL, /* 157 */ - EACCES, /* ERROR_NOT_LOCKED 158 */ - EINVAL, /* 159 */ - EINVAL, /* 160 */ - ENOENT, /* ERROR_BAD_PATHNAME 161 */ - EINVAL, /* 162 */ - EINVAL, /* 163 */ - EINVAL, /* 164 */ - EINVAL, /* 165 */ - EINVAL, /* 166 */ - EACCES, /* ERROR_LOCK_FAILED 167 */ - EINVAL, /* 168 */ - EINVAL, /* 169 */ - EINVAL, /* 170 */ - EINVAL, /* 171 */ - EINVAL, /* 172 */ - EINVAL, /* 173 */ - EINVAL, /* 174 */ - EINVAL, /* 175 */ - EINVAL, /* 176 */ - EINVAL, /* 177 */ - EINVAL, /* 178 */ - EINVAL, /* 179 */ - EINVAL, /* 180 */ - EINVAL, /* 181 */ - EINVAL, /* 182 */ - EEXIST, /* ERROR_ALREADY_EXISTS 183 */ - ECHILD, /* ERROR_NO_CHILD_PROCESS 184 */ - EINVAL, /* 185 */ - EINVAL, /* 186 */ - EINVAL, /* 187 */ - EINVAL, /* 188 */ - EINVAL, /* 189 */ - EINVAL, /* 190 */ - EINVAL, /* 191 */ - EINVAL, /* 192 */ - EINVAL, /* 193 */ - EINVAL, /* 194 */ - EINVAL, /* 195 */ - EINVAL, /* 196 */ - EINVAL, /* 197 */ - EINVAL, /* 198 */ - EINVAL, /* 199 */ - EINVAL, /* 200 */ - EINVAL, /* 201 */ - EINVAL, /* 202 */ - EINVAL, /* 203 */ - EINVAL, /* 204 */ - EINVAL, /* 205 */ - ENAMETOOLONG,/* ERROR_FILENAME_EXCED_RANGE 206 */ - EINVAL, /* 207 */ - EINVAL, /* 208 */ - EINVAL, /* 209 */ - EINVAL, /* 210 */ - EINVAL, /* 211 */ - EINVAL, /* 212 */ - EINVAL, /* 213 */ - EINVAL, /* 214 */ - EINVAL, /* 215 */ - EINVAL, /* 216 */ - EINVAL, /* 217 */ - EINVAL, /* 218 */ - EINVAL, /* 219 */ - EINVAL, /* 220 */ - EINVAL, /* 221 */ - EINVAL, /* 222 */ - EINVAL, /* 223 */ - EINVAL, /* 224 */ - EINVAL, /* 225 */ - EINVAL, /* 226 */ - EINVAL, /* 227 */ - EINVAL, /* 228 */ - EINVAL, /* 229 */ - EPIPE, /* ERROR_BAD_PIPE 230 */ - EAGAIN, /* ERROR_PIPE_BUSY 231 */ - EPIPE, /* ERROR_NO_DATA 232 */ - EPIPE, /* ERROR_PIPE_NOT_CONNECTED 233 */ - EINVAL, /* 234 */ - EINVAL, /* 235 */ - EINVAL, /* 236 */ - EINVAL, /* 237 */ - EINVAL, /* 238 */ - EINVAL, /* 239 */ - EINVAL, /* 240 */ - EINVAL, /* 241 */ - EINVAL, /* 242 */ - EINVAL, /* 243 */ - EINVAL, /* 244 */ - EINVAL, /* 245 */ - EINVAL, /* 246 */ - EINVAL, /* 247 */ - EINVAL, /* 248 */ - EINVAL, /* 249 */ - EINVAL, /* 250 */ - EINVAL, /* 251 */ - EINVAL, /* 252 */ - EINVAL, /* 253 */ - EINVAL, /* 254 */ - EINVAL, /* 255 */ - EINVAL, /* 256 */ - EINVAL, /* 257 */ - EINVAL, /* 258 */ - EINVAL, /* 259 */ - EINVAL, /* 260 */ - EINVAL, /* 261 */ - EINVAL, /* 262 */ - EINVAL, /* 263 */ - EINVAL, /* 264 */ - EINVAL, /* 265 */ - EINVAL, /* 266 */ - ENOTDIR, /* ERROR_DIRECTORY 267 */ -}; - -static const unsigned int tableLen = sizeof(errorTable); - -/* - * The following table contains the mapping from WinSock errors to - * errno errors. - */ - -static int wsaErrorTable[] = { - EWOULDBLOCK, /* WSAEWOULDBLOCK */ - EINPROGRESS, /* WSAEINPROGRESS */ - EALREADY, /* WSAEALREADY */ - ENOTSOCK, /* WSAENOTSOCK */ - EDESTADDRREQ, /* WSAEDESTADDRREQ */ - EMSGSIZE, /* WSAEMSGSIZE */ - EPROTOTYPE, /* WSAEPROTOTYPE */ - ENOPROTOOPT, /* WSAENOPROTOOPT */ - EPROTONOSUPPORT, /* WSAEPROTONOSUPPORT */ - ESOCKTNOSUPPORT, /* WSAESOCKTNOSUPPORT */ - EOPNOTSUPP, /* WSAEOPNOTSUPP */ - EPFNOSUPPORT, /* WSAEPFNOSUPPORT */ - EAFNOSUPPORT, /* WSAEAFNOSUPPORT */ - EADDRINUSE, /* WSAEADDRINUSE */ - EADDRNOTAVAIL, /* WSAEADDRNOTAVAIL */ - ENETDOWN, /* WSAENETDOWN */ - ENETUNREACH, /* WSAENETUNREACH */ - ENETRESET, /* WSAENETRESET */ - ECONNABORTED, /* WSAECONNABORTED */ - ECONNRESET, /* WSAECONNRESET */ - ENOBUFS, /* WSAENOBUFS */ - EISCONN, /* WSAEISCONN */ - ENOTCONN, /* WSAENOTCONN */ - ESHUTDOWN, /* WSAESHUTDOWN */ - ETOOMANYREFS, /* WSAETOOMANYREFS */ - ETIMEDOUT, /* WSAETIMEDOUT */ - ECONNREFUSED, /* WSAECONNREFUSED */ - ELOOP, /* WSAELOOP */ - ENAMETOOLONG, /* WSAENAMETOOLONG */ - EHOSTDOWN, /* WSAEHOSTDOWN */ - EHOSTUNREACH, /* WSAEHOSTUNREACH */ - ENOTEMPTY, /* WSAENOTEMPTY */ - EAGAIN, /* WSAEPROCLIM */ - EUSERS, /* WSAEUSERS */ - EDQUOT, /* WSAEDQUOT */ - ESTALE, /* WSAESTALE */ - EREMOTE, /* WSAEREMOTE */ -}; - -/* - *---------------------------------------------------------------------- - * - * TclWinConvertError -- - * - * This routine converts a Win32 error into an errno value. - * - * Results: - * None. - * - * Side effects: - * Sets the errno global variable. - * - *---------------------------------------------------------------------- - */ - -void -TclWinConvertError(errCode) - DWORD errCode; /* Win32 error code. */ -{ - if (errCode >= tableLen) { - Tcl_SetErrno(EINVAL); - } else { - Tcl_SetErrno(errorTable[errCode]); - } -} - -/* - *---------------------------------------------------------------------- - * - * TclWinConvertWSAError -- - * - * This routine converts a WinSock error into an errno value. - * - * Results: - * None. - * - * Side effects: - * Sets the errno global variable. - * - *---------------------------------------------------------------------- - */ - -void -TclWinConvertWSAError(errCode) - DWORD errCode; /* Win32 error code. */ -{ - if ((errCode >= WSAEWOULDBLOCK) && (errCode <= WSAEREMOTE)) { - Tcl_SetErrno(wsaErrorTable[errCode - WSAEWOULDBLOCK]); - } else { - Tcl_SetErrno(EINVAL); - } -} diff --git a/win/tclWinFCmd.c b/win/tclWinFCmd.c deleted file mode 100644 index 97eeacb..0000000 --- a/win/tclWinFCmd.c +++ /dev/null @@ -1,1664 +0,0 @@ -/* - * tclWinFCmd.c - * - * This file implements the Windows specific portion of file manipulation - * subcommands of the "file" command. - * - * Copyright (c) 1996-1998 Sun Microsystems, Inc. - * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclWinFCmd.c,v 1.7.2.1 2000/08/07 21:33:02 hobbs Exp $ - */ - -#include "tclWinInt.h" - -/* - * The following constants specify the type of callback when - * TraverseWinTree() calls the traverseProc() - */ - -#define DOTREE_PRED 1 /* pre-order directory */ -#define DOTREE_POSTD 2 /* post-order directory */ -#define DOTREE_F 3 /* regular file */ - -/* - * Callbacks for file attributes code. - */ - -static int GetWinFileAttributes _ANSI_ARGS_((Tcl_Interp *interp, - int objIndex, CONST char *fileName, - Tcl_Obj **attributePtrPtr)); -static int GetWinFileLongName _ANSI_ARGS_((Tcl_Interp *interp, - int objIndex, CONST char *fileName, - Tcl_Obj **attributePtrPtr)); -static int GetWinFileShortName _ANSI_ARGS_((Tcl_Interp *interp, - int objIndex, CONST char *fileName, - Tcl_Obj **attributePtrPtr)); -static int SetWinFileAttributes _ANSI_ARGS_((Tcl_Interp *interp, - int objIndex, CONST char *fileName, - Tcl_Obj *attributePtr)); -static int CannotSetAttribute _ANSI_ARGS_((Tcl_Interp *interp, - int objIndex, CONST char *fileName, - Tcl_Obj *attributePtr)); - -/* - * Constants and variables necessary for file attributes subcommand. - */ - -enum { - WIN_ARCHIVE_ATTRIBUTE, - WIN_HIDDEN_ATTRIBUTE, - WIN_LONGNAME_ATTRIBUTE, - WIN_READONLY_ATTRIBUTE, - WIN_SHORTNAME_ATTRIBUTE, - WIN_SYSTEM_ATTRIBUTE -}; - -static int attributeArray[] = {FILE_ATTRIBUTE_ARCHIVE, FILE_ATTRIBUTE_HIDDEN, - 0, FILE_ATTRIBUTE_READONLY, 0, FILE_ATTRIBUTE_SYSTEM}; - - -char *tclpFileAttrStrings[] = { - "-archive", "-hidden", "-longname", "-readonly", - "-shortname", "-system", (char *) NULL -}; - -const TclFileAttrProcs tclpFileAttrProcs[] = { - {GetWinFileAttributes, SetWinFileAttributes}, - {GetWinFileAttributes, SetWinFileAttributes}, - {GetWinFileLongName, CannotSetAttribute}, - {GetWinFileAttributes, SetWinFileAttributes}, - {GetWinFileShortName, CannotSetAttribute}, - {GetWinFileAttributes, SetWinFileAttributes}}; - -/* - * Prototype for the TraverseWinTree callback function. - */ - -typedef int (TraversalProc)(Tcl_DString *srcPtr, Tcl_DString *dstPtr, - int type, Tcl_DString *errorPtr); - -/* - * Declarations for local procedures defined in this file: - */ - -static void StatError(Tcl_Interp *interp, CONST char *fileName); -static int ConvertFileNameFormat(Tcl_Interp *interp, - int objIndex, CONST char *fileName, int longShort, - Tcl_Obj **attributePtrPtr); -static int DoCopyFile(Tcl_DString *srcPtr, Tcl_DString *dstPtr); -static int DoCreateDirectory(Tcl_DString *pathPtr); -static int DoDeleteFile(Tcl_DString *pathPtr); -static int DoRemoveDirectory(Tcl_DString *pathPtr, int recursive, - Tcl_DString *errorPtr); -static int DoRenameFile(const TCHAR *nativeSrc, Tcl_DString *dstPtr); -static int TraversalCopy(Tcl_DString *srcPtr, Tcl_DString *dstPtr, - int type, Tcl_DString *errorPtr); -static int TraversalDelete(Tcl_DString *srcPtr, Tcl_DString *dstPtr, - int type, Tcl_DString *errorPtr); -static int TraverseWinTree(TraversalProc *traverseProc, - Tcl_DString *sourcePtr, Tcl_DString *dstPtr, - Tcl_DString *errorPtr); - - -/* - *--------------------------------------------------------------------------- - * - * TclpRenameFile, DoRenameFile -- - * - * Changes the name of an existing file or directory, from src to dst. - * If src and dst refer to the same file or directory, does nothing - * and returns success. Otherwise if dst already exists, it will be - * deleted and replaced by src subject to the following conditions: - * If src is a directory, dst may be an empty directory. - * If src is a file, dst may be a file. - * In any other situation where dst already exists, the rename will - * fail. - * - * Results: - * If the file or directory was successfully renamed, returns TCL_OK. - * Otherwise the return value is TCL_ERROR and errno is set to - * indicate the error. Some possible values for errno are: - * - * ENAMETOOLONG: src or dst names are too long. - * EACCES: src or dst parent directory can't be read and/or written. - * EEXIST: dst is a non-empty directory. - * EINVAL: src is a root directory or dst is a subdirectory of src. - * EISDIR: dst is a directory, but src is not. - * ENOENT: src doesn't exist. src or dst is "". - * ENOTDIR: src is a directory, but dst is not. - * EXDEV: src and dst are on different filesystems. - * - * EACCES: exists an open file already referring to src or dst. - * EACCES: src or dst specify the current working directory (NT). - * EACCES: src specifies a char device (nul:, com1:, etc.) - * EEXIST: dst specifies a char device (nul:, com1:, etc.) (NT) - * EACCES: dst specifies a char device (nul:, com1:, etc.) (95) - * - * Side effects: - * The implementation supports cross-filesystem renames of files, - * but the caller should be prepared to emulate cross-filesystem - * renames of directories if errno is EXDEV. - * - *--------------------------------------------------------------------------- - */ - -int -TclpRenameFile( - CONST char *src, /* Pathname of file or dir to be renamed - * (UTF-8). */ - CONST char *dst) /* New pathname of file or directory - * (UTF-8). */ -{ - int result; - TCHAR *nativeSrc; - Tcl_DString srcString, dstString; - - nativeSrc = Tcl_WinUtfToTChar(src, -1, &srcString); - Tcl_WinUtfToTChar(dst, -1, &dstString); - - result = DoRenameFile(nativeSrc, &dstString); - Tcl_DStringFree(&srcString); - Tcl_DStringFree(&dstString); - return result; -} - -static int -DoRenameFile( - CONST TCHAR *nativeSrc, /* Pathname of file or dir to be renamed - * (native). */ - Tcl_DString *dstPtr) /* New pathname for file or directory - * (native). */ -{ - const TCHAR *nativeDst; - DWORD srcAttr, dstAttr; - - nativeDst = (TCHAR *) Tcl_DStringValue(dstPtr); - - /* - * Would throw an exception under NT if one of the arguments is a - * char block device. - */ - - __try { - if ((*tclWinProcs->moveFileProc)(nativeSrc, nativeDst) != FALSE) { - return TCL_OK; - } - } __except (-1) {} - - TclWinConvertError(GetLastError()); - - srcAttr = (*tclWinProcs->getFileAttributesProc)(nativeSrc); - dstAttr = (*tclWinProcs->getFileAttributesProc)(nativeDst); - if (srcAttr == 0xffffffff) { - if ((*tclWinProcs->getFullPathNameProc)(nativeSrc, 0, NULL, NULL) >= MAX_PATH) { - errno = ENAMETOOLONG; - return TCL_ERROR; - } - srcAttr = 0; - } - if (dstAttr == 0xffffffff) { - if ((*tclWinProcs->getFullPathNameProc)(nativeDst, 0, NULL, NULL) >= MAX_PATH) { - errno = ENAMETOOLONG; - return TCL_ERROR; - } - dstAttr = 0; - } - - if (errno == EBADF) { - errno = EACCES; - return TCL_ERROR; - } - if (errno == EACCES) { - decode: - if (srcAttr & FILE_ATTRIBUTE_DIRECTORY) { - TCHAR *nativeSrcRest, *nativeDstRest; - char **srcArgv, **dstArgv; - int size, srcArgc, dstArgc; - WCHAR nativeSrcPath[MAX_PATH]; - WCHAR nativeDstPath[MAX_PATH]; - Tcl_DString srcString, dstString; - CONST char *src, *dst; - - size = (*tclWinProcs->getFullPathNameProc)(nativeSrc, MAX_PATH, - nativeSrcPath, &nativeSrcRest); - if ((size == 0) || (size > MAX_PATH)) { - return TCL_ERROR; - } - size = (*tclWinProcs->getFullPathNameProc)(nativeDst, MAX_PATH, - nativeDstPath, &nativeDstRest); - if ((size == 0) || (size > MAX_PATH)) { - return TCL_ERROR; - } - (*tclWinProcs->charLowerProc)((TCHAR *) nativeSrcPath); - (*tclWinProcs->charLowerProc)((TCHAR *) nativeDstPath); - - src = Tcl_WinTCharToUtf((TCHAR *) nativeSrcPath, -1, &srcString); - dst = Tcl_WinTCharToUtf((TCHAR *) nativeDstPath, -1, &dstString); - if (strncmp(src, dst, (size_t) Tcl_DStringLength(&srcString)) == 0) { - /* - * Trying to move a directory into itself. - */ - - errno = EINVAL; - Tcl_DStringFree(&srcString); - Tcl_DStringFree(&dstString); - return TCL_ERROR; - } - Tcl_SplitPath(src, &srcArgc, &srcArgv); - Tcl_SplitPath(dst, &dstArgc, &dstArgv); - Tcl_DStringFree(&srcString); - Tcl_DStringFree(&dstString); - - if (srcArgc == 1) { - /* - * They are trying to move a root directory. Whether - * or not it is across filesystems, this cannot be - * done. - */ - - Tcl_SetErrno(EINVAL); - } else if ((srcArgc > 0) && (dstArgc > 0) && - (strcmp(srcArgv[0], dstArgv[0]) != 0)) { - /* - * If src is a directory and dst filesystem != src - * filesystem, errno should be EXDEV. It is very - * important to get this behavior, so that the caller - * can respond to a cross filesystem rename by - * simulating it with copy and delete. The MoveFile - * system call already handles the case of moving a - * file between filesystems. - */ - - Tcl_SetErrno(EXDEV); - } - - ckfree((char *) srcArgv); - ckfree((char *) dstArgv); - } - - /* - * Other types of access failure is that dst is a read-only - * filesystem, that an open file referred to src or dest, or that - * src or dest specified the current working directory on the - * current filesystem. EACCES is returned for those cases. - */ - - } else if (Tcl_GetErrno() == EEXIST) { - /* - * Reports EEXIST any time the target already exists. If it makes - * sense, remove the old file and try renaming again. - */ - - if (srcAttr & FILE_ATTRIBUTE_DIRECTORY) { - if (dstAttr & FILE_ATTRIBUTE_DIRECTORY) { - /* - * Overwrite empty dst directory with src directory. The - * following call will remove an empty directory. If it - * fails, it's because it wasn't empty. - */ - - if (DoRemoveDirectory(dstPtr, 0, NULL) == TCL_OK) { - /* - * Now that that empty directory is gone, we can try - * renaming again. If that fails, we'll put this empty - * directory back, for completeness. - */ - - if ((*tclWinProcs->moveFileProc)(nativeSrc, nativeDst) != FALSE) { - return TCL_OK; - } - - /* - * Some new error has occurred. Don't know what it - * could be, but report this one. - */ - - TclWinConvertError(GetLastError()); - (*tclWinProcs->createDirectoryProc)(nativeDst, NULL); - (*tclWinProcs->setFileAttributesProc)(nativeDst, dstAttr); - if (Tcl_GetErrno() == EACCES) { - /* - * Decode the EACCES to a more meaningful error. - */ - - goto decode; - } - } - } else { /* (dstAttr & FILE_ATTRIBUTE_DIRECTORY) == 0 */ - Tcl_SetErrno(ENOTDIR); - } - } else { /* (srcAttr & FILE_ATTRIBUTE_DIRECTORY) == 0 */ - if (dstAttr & FILE_ATTRIBUTE_DIRECTORY) { - Tcl_SetErrno(EISDIR); - } else { - /* - * Overwrite existing file by: - * - * 1. Rename existing file to temp name. - * 2. Rename old file to new name. - * 3. If success, delete temp file. If failure, - * put temp file back to old name. - */ - - TCHAR *nativeRest, *nativeTmp, *nativePrefix; - int result, size; - WCHAR tempBuf[MAX_PATH]; - - size = (*tclWinProcs->getFullPathNameProc)(nativeDst, MAX_PATH, - tempBuf, &nativeRest); - if ((size == 0) || (size > MAX_PATH) || (nativeRest == NULL)) { - return TCL_ERROR; - } - nativeTmp = (TCHAR *) tempBuf; - ((char *) nativeRest)[0] = '\0'; - ((char *) nativeRest)[1] = '\0'; /* In case it's Unicode. */ - - result = TCL_ERROR; - nativePrefix = (tclWinProcs->useWide) - ? (TCHAR *) L"tclr" : (TCHAR *) "tclr"; - if ((*tclWinProcs->getTempFileNameProc)(nativeTmp, - nativePrefix, 0, tempBuf) != 0) { - /* - * Strictly speaking, need the following DeleteFile and - * MoveFile to be joined as an atomic operation so no - * other app comes along in the meantime and creates the - * same temp file. - */ - - nativeTmp = (TCHAR *) tempBuf; - (*tclWinProcs->deleteFileProc)(nativeTmp); - if ((*tclWinProcs->moveFileProc)(nativeDst, nativeTmp) != FALSE) { - if ((*tclWinProcs->moveFileProc)(nativeSrc, nativeDst) != FALSE) { - (*tclWinProcs->setFileAttributesProc)(nativeTmp, - FILE_ATTRIBUTE_NORMAL); - (*tclWinProcs->deleteFileProc)(nativeTmp); - return TCL_OK; - } else { - (*tclWinProcs->deleteFileProc)(nativeDst); - (*tclWinProcs->moveFileProc)(nativeTmp, nativeDst); - } - } - - /* - * Can't backup dst file or move src file. Return that - * error. Could happen if an open file refers to dst. - */ - - TclWinConvertError(GetLastError()); - if (Tcl_GetErrno() == EACCES) { - /* - * Decode the EACCES to a more meaningful error. - */ - - goto decode; - } - } - return result; - } - } - } - return TCL_ERROR; -} - -/* - *--------------------------------------------------------------------------- - * - * TclpCopyFile, DoCopyFile -- - * - * Copy a single file (not a directory). If dst already exists and - * is not a directory, it is removed. - * - * Results: - * If the file was successfully copied, returns TCL_OK. Otherwise - * the return value is TCL_ERROR and errno is set to indicate the - * error. Some possible values for errno are: - * - * EACCES: src or dst parent directory can't be read and/or written. - * EISDIR: src or dst is a directory. - * ENOENT: src doesn't exist. src or dst is "". - * - * EACCES: exists an open file already referring to dst (95). - * EACCES: src specifies a char device (nul:, com1:, etc.) (NT) - * ENOENT: src specifies a char device (nul:, com1:, etc.) (95) - * - * Side effects: - * It is not an error to copy to a char device. - * - *--------------------------------------------------------------------------- - */ - -int -TclpCopyFile( - CONST char *src, /* Pathname of file to be copied (UTF-8). */ - CONST char *dst) /* Pathname of file to copy to (UTF-8). */ -{ - int result; - Tcl_DString srcString, dstString; - - Tcl_WinUtfToTChar(src, -1, &srcString); - Tcl_WinUtfToTChar(dst, -1, &dstString); - result = DoCopyFile(&srcString, &dstString); - Tcl_DStringFree(&srcString); - Tcl_DStringFree(&dstString); - return result; -} - -static int -DoCopyFile( - Tcl_DString *srcPtr, /* Pathname of file to be copied (native). */ - Tcl_DString *dstPtr) /* Pathname of file to copy to (native). */ -{ - CONST TCHAR *nativeSrc, *nativeDst; - - nativeSrc = (TCHAR *) Tcl_DStringValue(srcPtr); - nativeDst = (TCHAR *) Tcl_DStringValue(dstPtr); - - /* - * Would throw an exception under NT if one of the arguments is a char - * block device. - */ - - __try { - if ((*tclWinProcs->copyFileProc)(nativeSrc, nativeDst, 0) != FALSE) { - return TCL_OK; - } - } __except (-1) {} - - TclWinConvertError(GetLastError()); - if (Tcl_GetErrno() == EBADF) { - Tcl_SetErrno(EACCES); - return TCL_ERROR; - } - if (Tcl_GetErrno() == EACCES) { - DWORD srcAttr, dstAttr; - - srcAttr = (*tclWinProcs->getFileAttributesProc)(nativeSrc); - dstAttr = (*tclWinProcs->getFileAttributesProc)(nativeDst); - if (srcAttr != 0xffffffff) { - if (dstAttr == 0xffffffff) { - dstAttr = 0; - } - if ((srcAttr & FILE_ATTRIBUTE_DIRECTORY) || - (dstAttr & FILE_ATTRIBUTE_DIRECTORY)) { - Tcl_SetErrno(EISDIR); - } - if (dstAttr & FILE_ATTRIBUTE_READONLY) { - (*tclWinProcs->setFileAttributesProc)(nativeDst, - dstAttr & ~FILE_ATTRIBUTE_READONLY); - if ((*tclWinProcs->copyFileProc)(nativeSrc, nativeDst, 0) != FALSE) { - return TCL_OK; - } - /* - * Still can't copy onto dst. Return that error, and - * restore attributes of dst. - */ - - TclWinConvertError(GetLastError()); - (*tclWinProcs->setFileAttributesProc)(nativeDst, dstAttr); - } - } - } - return TCL_ERROR; -} - -/* - *--------------------------------------------------------------------------- - * - * TclpDeleteFile, DoDeleteFile -- - * - * Removes a single file (not a directory). - * - * Results: - * If the file was successfully deleted, returns TCL_OK. Otherwise - * the return value is TCL_ERROR and errno is set to indicate the - * error. Some possible values for errno are: - * - * EACCES: a parent directory can't be read and/or written. - * EISDIR: path is a directory. - * ENOENT: path doesn't exist or is "". - * - * EACCES: exists an open file already referring to path. - * EACCES: path is a char device (nul:, com1:, etc.) - * - * Side effects: - * The file is deleted, even if it is read-only. - * - *--------------------------------------------------------------------------- - */ - -int -TclpDeleteFile( - CONST char *path) /* Pathname of file to be removed (UTF-8). */ -{ - int result; - Tcl_DString pathString; - - Tcl_WinUtfToTChar(path, -1, &pathString); - result = DoDeleteFile(&pathString); - Tcl_DStringFree(&pathString); - return result; -} - -static int -DoDeleteFile( - Tcl_DString *pathPtr) /* Pathname of file to be removed (native). */ -{ - DWORD attr; - CONST TCHAR *nativePath; - - nativePath = (TCHAR *) Tcl_DStringValue(pathPtr); - - if ((*tclWinProcs->deleteFileProc)(nativePath) != FALSE) { - return TCL_OK; - } - TclWinConvertError(GetLastError()); - - /* - * Win32s thinks that "" is the same as "." and then reports EISDIR - * instead of ENOENT. - */ - - if (tclWinProcs->useWide) { - if (((WCHAR *) nativePath)[0] == '\0') { - Tcl_SetErrno(ENOENT); - return TCL_ERROR; - } - } else { - if (((char *) nativePath)[0] == '\0') { - Tcl_SetErrno(ENOENT); - return TCL_ERROR; - } - } - if (Tcl_GetErrno() == EACCES) { - attr = (*tclWinProcs->getFileAttributesProc)(nativePath); - if (attr != 0xffffffff) { - if (attr & FILE_ATTRIBUTE_DIRECTORY) { - /* - * Windows NT reports removing a directory as EACCES instead - * of EISDIR. - */ - - Tcl_SetErrno(EISDIR); - } else if (attr & FILE_ATTRIBUTE_READONLY) { - (*tclWinProcs->setFileAttributesProc)(nativePath, - attr & ~FILE_ATTRIBUTE_READONLY); - if ((*tclWinProcs->deleteFileProc)(nativePath) != FALSE) { - return TCL_OK; - } - TclWinConvertError(GetLastError()); - (*tclWinProcs->setFileAttributesProc)(nativePath, attr); - } - } - } else if (Tcl_GetErrno() == ENOENT) { - attr = (*tclWinProcs->getFileAttributesProc)(nativePath); - if (attr != 0xffffffff) { - if (attr & FILE_ATTRIBUTE_DIRECTORY) { - /* - * Windows 95 reports removing a directory as ENOENT instead - * of EISDIR. - */ - - Tcl_SetErrno(EISDIR); - } - } - } else if (Tcl_GetErrno() == EINVAL) { - /* - * Windows NT reports removing a char device as EINVAL instead of - * EACCES. - */ - - Tcl_SetErrno(EACCES); - } - - return TCL_ERROR; -} - -/* - *--------------------------------------------------------------------------- - * - * TclpCreateDirectory -- - * - * Creates the specified directory. All parent directories of the - * specified directory must already exist. The directory is - * automatically created with permissions so that user can access - * the new directory and create new files or subdirectories in it. - * - * Results: - * If the directory was successfully created, returns TCL_OK. - * Otherwise the return value is TCL_ERROR and errno is set to - * indicate the error. Some possible values for errno are: - * - * EACCES: a parent directory can't be read and/or written. - * EEXIST: path already exists. - * ENOENT: a parent directory doesn't exist. - * - * Side effects: - * A directory is created. - * - *--------------------------------------------------------------------------- - */ - -int -TclpCreateDirectory( - CONST char *path) /* Pathname of directory to create (UTF-8). */ -{ - int result; - Tcl_DString pathString; - - Tcl_WinUtfToTChar(path, -1, &pathString); - result = DoCreateDirectory(&pathString); - Tcl_DStringFree(&pathString); - return result; -} - -static int -DoCreateDirectory( - Tcl_DString *pathPtr) /* Pathname of directory to create (native). */ -{ - DWORD error; - CONST TCHAR *nativePath; - - nativePath = (TCHAR *) Tcl_DStringValue(pathPtr); - if ((*tclWinProcs->createDirectoryProc)(nativePath, NULL) == 0) { - error = GetLastError(); - TclWinConvertError(error); - return TCL_ERROR; - } - return TCL_OK; -} - -/* - *--------------------------------------------------------------------------- - * - * TclpCopyDirectory -- - * - * Recursively copies a directory. The target directory dst must - * not already exist. Note that this function does not merge two - * directory hierarchies, even if the target directory is an an - * empty directory. - * - * Results: - * If the directory was successfully copied, returns TCL_OK. - * Otherwise the return value is TCL_ERROR, errno is set to indicate - * the error, and the pathname of the file that caused the error - * is stored in errorPtr. See TclpCreateDirectory and TclpCopyFile - * for a description of possible values for errno. - * - * Side effects: - * An exact copy of the directory hierarchy src will be created - * with the name dst. If an error occurs, the error will - * be returned immediately, and remaining files will not be - * processed. - * - *--------------------------------------------------------------------------- - */ - -int -TclpCopyDirectory( - CONST char *src, /* Pathname of directory to be copied - * (UTF-8). */ - CONST char *dst, /* Pathname of target directory (UTF-8). */ - Tcl_DString *errorPtr) /* If non-NULL, uninitialized or free - * DString filled with UTF-8 name of file - * causing error. */ -{ - int result; - Tcl_DString srcString, dstString; - - Tcl_WinUtfToTChar(src, -1, &srcString); - Tcl_WinUtfToTChar(dst, -1, &dstString); - - result = TraverseWinTree(TraversalCopy, &srcString, &dstString, errorPtr); - - Tcl_DStringFree(&srcString); - Tcl_DStringFree(&dstString); - return result; -} - -/* - *---------------------------------------------------------------------- - * - * TclpRemoveDirectory, DoRemoveDirectory -- - * - * Removes directory (and its contents, if the recursive flag is set). - * - * Results: - * If the directory was successfully removed, returns TCL_OK. - * Otherwise the return value is TCL_ERROR, errno is set to indicate - * the error, and the pathname of the file that caused the error - * is stored in errorPtr. Some possible values for errno are: - * - * EACCES: path directory can't be read and/or written. - * EEXIST: path is a non-empty directory. - * EINVAL: path is root directory or current directory. - * ENOENT: path doesn't exist or is "". - * ENOTDIR: path is not a directory. - * - * EACCES: path is a char device (nul:, com1:, etc.) (95) - * EINVAL: path is a char device (nul:, com1:, etc.) (NT) - * - * Side effects: - * Directory removed. If an error occurs, the error will be returned - * immediately, and remaining files will not be deleted. - * - *---------------------------------------------------------------------- - */ - -int -TclpRemoveDirectory( - CONST char *path, /* Pathname of directory to be removed - * (UTF-8). */ - int recursive, /* If non-zero, removes directories that - * are nonempty. Otherwise, will only remove - * empty directories. */ - Tcl_DString *errorPtr) /* If non-NULL, uninitialized or free - * DString filled with UTF-8 name of file - * causing error. */ -{ - int result; - Tcl_DString pathString; - - Tcl_WinUtfToTChar(path, -1, &pathString); - result = DoRemoveDirectory(&pathString, recursive, errorPtr); - Tcl_DStringFree(&pathString); - - return result; -} - -static int -DoRemoveDirectory( - Tcl_DString *pathPtr, /* Pathname of directory to be removed - * (native). */ - int recursive, /* If non-zero, removes directories that - * are nonempty. Otherwise, will only remove - * empty directories. */ - Tcl_DString *errorPtr) /* If non-NULL, uninitialized or free - * DString filled with UTF-8 name of file - * causing error. */ -{ - CONST TCHAR *nativePath; - DWORD attr; - - nativePath = (TCHAR *) Tcl_DStringValue(pathPtr); - - if ((*tclWinProcs->removeDirectoryProc)(nativePath) != FALSE) { - return TCL_OK; - } - TclWinConvertError(GetLastError()); - - /* - * Win32s thinks that "" is the same as "." and then reports EACCES - * instead of ENOENT. - */ - - - if (tclWinProcs->useWide) { - if (((WCHAR *) nativePath)[0] == '\0') { - Tcl_SetErrno(ENOENT); - return TCL_ERROR; - } - } else { - if (((char *) nativePath)[0] == '\0') { - Tcl_SetErrno(ENOENT); - return TCL_ERROR; - } - } - if (Tcl_GetErrno() == EACCES) { - attr = (*tclWinProcs->getFileAttributesProc)(nativePath); - if (attr != 0xffffffff) { - if ((attr & FILE_ATTRIBUTE_DIRECTORY) == 0) { - /* - * Windows 95 reports calling RemoveDirectory on a file as an - * EACCES, not an ENOTDIR. - */ - - Tcl_SetErrno(ENOTDIR); - goto end; - } - - if (attr & FILE_ATTRIBUTE_READONLY) { - attr &= ~FILE_ATTRIBUTE_READONLY; - if ((*tclWinProcs->setFileAttributesProc)(nativePath, attr) == FALSE) { - goto end; - } - if ((*tclWinProcs->removeDirectoryProc)(nativePath) != FALSE) { - return TCL_OK; - } - TclWinConvertError(GetLastError()); - (*tclWinProcs->setFileAttributesProc)(nativePath, - attr | FILE_ATTRIBUTE_READONLY); - } - - /* - * Windows 95 and Win32s report removing a non-empty directory - * as EACCES, not EEXIST. If the directory is not empty, - * change errno so caller knows what's going on. - */ - - if (TclWinGetPlatformId() != VER_PLATFORM_WIN32_NT) { - char *path, *find; - HANDLE handle; - WIN32_FIND_DATAA data; - Tcl_DString buffer; - int len; - - path = (char *) nativePath; - - Tcl_DStringInit(&buffer); - len = strlen(path); - find = Tcl_DStringAppend(&buffer, path, len); - if ((len > 0) && (find[len - 1] != '\\')) { - Tcl_DStringAppend(&buffer, "\\", 1); - } - find = Tcl_DStringAppend(&buffer, "*.*", 3); - handle = FindFirstFileA(find, &data); - if (handle != INVALID_HANDLE_VALUE) { - while (1) { - if ((strcmp(data.cFileName, ".") != 0) - && (strcmp(data.cFileName, "..") != 0)) { - /* - * Found something in this directory. - */ - - Tcl_SetErrno(EEXIST); - break; - } - if (FindNextFileA(handle, &data) == FALSE) { - break; - } - } - FindClose(handle); - } - Tcl_DStringFree(&buffer); - } - } - } - if (Tcl_GetErrno() == ENOTEMPTY) { - /* - * The caller depends on EEXIST to signify that the directory is - * not empty, not ENOTEMPTY. - */ - - Tcl_SetErrno(EEXIST); - } - if ((recursive != 0) && (Tcl_GetErrno() == EEXIST)) { - /* - * The directory is nonempty, but the recursive flag has been - * specified, so we recursively remove all the files in the directory. - */ - - return TraverseWinTree(TraversalDelete, pathPtr, NULL, errorPtr); - } - - end: - if (errorPtr != NULL) { - Tcl_WinTCharToUtf(nativePath, -1, errorPtr); - } - return TCL_ERROR; -} - -/* - *--------------------------------------------------------------------------- - * - * TraverseWinTree -- - * - * Traverse directory tree specified by sourcePtr, calling the function - * traverseProc for each file and directory encountered. If destPtr - * is non-null, each of name in the sourcePtr directory is appended to - * the directory specified by destPtr and passed as the second argument - * to traverseProc() . - * - * Results: - * Standard Tcl result. - * - * Side effects: - * None caused by TraverseWinTree, however the user specified - * traverseProc() may change state. If an error occurs, the error will - * be returned immediately, and remaining files will not be processed. - * - *--------------------------------------------------------------------------- - */ - -static int -TraverseWinTree( - TraversalProc *traverseProc,/* Function to call for every file and - * directory in source hierarchy. */ - Tcl_DString *sourcePtr, /* Pathname of source directory to be - * traversed (native). */ - Tcl_DString *targetPtr, /* Pathname of directory to traverse in - * parallel with source directory (native). */ - Tcl_DString *errorPtr) /* If non-NULL, uninitialized or free - * DString filled with UTF-8 name of file - * causing error. */ -{ - DWORD sourceAttr; - TCHAR *nativeSource, *nativeErrfile; - int result, found, sourceLen, targetLen, oldSourceLen, oldTargetLen; - HANDLE handle; - WIN32_FIND_DATAT data; - - nativeErrfile = NULL; - result = TCL_OK; - oldTargetLen = 0; /* lint. */ - - nativeSource = (TCHAR *) Tcl_DStringValue(sourcePtr); - oldSourceLen = Tcl_DStringLength(sourcePtr); - sourceAttr = (*tclWinProcs->getFileAttributesProc)(nativeSource); - if (sourceAttr == 0xffffffff) { - nativeErrfile = nativeSource; - goto end; - } - if ((sourceAttr & FILE_ATTRIBUTE_DIRECTORY) == 0) { - /* - * Process the regular file - */ - - return (*traverseProc)(sourcePtr, targetPtr, DOTREE_F, errorPtr); - } - - if (tclWinProcs->useWide) { - Tcl_DStringAppend(sourcePtr, (char *) L"\\*.*", 4 * sizeof(WCHAR) + 1); - Tcl_DStringSetLength(sourcePtr, Tcl_DStringLength(sourcePtr) - 1); - } else { - Tcl_DStringAppend(sourcePtr, "\\*.*", 4); - } - nativeSource = (TCHAR *) Tcl_DStringValue(sourcePtr); - handle = (*tclWinProcs->findFirstFileProc)(nativeSource, &data); - if (handle == INVALID_HANDLE_VALUE) { - /* - * Can't read directory - */ - - TclWinConvertError(GetLastError()); - nativeErrfile = nativeSource; - goto end; - } - - nativeSource[oldSourceLen + 1] = '\0'; - Tcl_DStringSetLength(sourcePtr, oldSourceLen); - result = (*traverseProc)(sourcePtr, targetPtr, DOTREE_PRED, errorPtr); - if (result != TCL_OK) { - FindClose(handle); - return result; - } - - sourceLen = oldSourceLen; - - if (tclWinProcs->useWide) { - sourceLen += sizeof(WCHAR); - Tcl_DStringAppend(sourcePtr, (char *) L"\\", sizeof(WCHAR) + 1); - Tcl_DStringSetLength(sourcePtr, sourceLen); - } else { - sourceLen += 1; - Tcl_DStringAppend(sourcePtr, "\\", 1); - } - if (targetPtr != NULL) { - oldTargetLen = Tcl_DStringLength(targetPtr); - - targetLen = oldTargetLen; - if (tclWinProcs->useWide) { - targetLen += sizeof(WCHAR); - Tcl_DStringAppend(targetPtr, (char *) L"\\", sizeof(WCHAR) + 1); - Tcl_DStringSetLength(targetPtr, targetLen); - } else { - targetLen += 1; - Tcl_DStringAppend(targetPtr, "\\", 1); - } - } - - found = 1; - for ( ; found; found = (*tclWinProcs->findNextFileProc)(handle, &data)) { - TCHAR *nativeName; - int len; - - if (tclWinProcs->useWide) { - WCHAR *wp; - - wp = data.w.cFileName; - if (*wp == '.') { - wp++; - if (*wp == '.') { - wp++; - } - if (*wp == '\0') { - continue; - } - } - nativeName = (TCHAR *) data.w.cFileName; - len = Tcl_UniCharLen(data.w.cFileName) * sizeof(WCHAR); - } else { - if ((strcmp(data.a.cFileName, ".") == 0) - || (strcmp(data.a.cFileName, "..") == 0)) { - continue; - } - nativeName = (TCHAR *) data.a.cFileName; - len = strlen(data.a.cFileName); - } - - /* - * Append name after slash, and recurse on the file. - */ - - Tcl_DStringAppend(sourcePtr, (char *) nativeName, len + 1); - Tcl_DStringSetLength(sourcePtr, Tcl_DStringLength(sourcePtr) - 1); - if (targetPtr != NULL) { - Tcl_DStringAppend(targetPtr, (char *) nativeName, len + 1); - Tcl_DStringSetLength(targetPtr, Tcl_DStringLength(targetPtr) - 1); - } - result = TraverseWinTree(traverseProc, sourcePtr, targetPtr, - errorPtr); - if (result != TCL_OK) { - break; - } - - /* - * Remove name after slash. - */ - - Tcl_DStringSetLength(sourcePtr, sourceLen); - if (targetPtr != NULL) { - Tcl_DStringSetLength(targetPtr, targetLen); - } - } - FindClose(handle); - - /* - * Strip off the trailing slash we added - */ - - Tcl_DStringSetLength(sourcePtr, oldSourceLen + 1); - Tcl_DStringSetLength(sourcePtr, oldSourceLen); - if (targetPtr != NULL) { - Tcl_DStringSetLength(targetPtr, oldTargetLen + 1); - Tcl_DStringSetLength(targetPtr, oldTargetLen); - } - if (result == TCL_OK) { - /* - * Call traverseProc() on a directory after visiting all the - * files in that directory. - */ - - result = (*traverseProc)(sourcePtr, targetPtr, DOTREE_POSTD, - errorPtr); - } - end: - if (nativeErrfile != NULL) { - TclWinConvertError(GetLastError()); - if (errorPtr != NULL) { - Tcl_WinTCharToUtf(nativeErrfile, -1, errorPtr); - } - result = TCL_ERROR; - } - - return result; -} - -/* - *---------------------------------------------------------------------- - * - * TraversalCopy - * - * Called from TraverseUnixTree in order to execute a recursive - * copy of a directory. - * - * Results: - * Standard Tcl result. - * - * Side effects: - * Depending on the value of type, src may be copied to dst. - * - *---------------------------------------------------------------------- - */ - -static int -TraversalCopy( - Tcl_DString *srcPtr, /* Source pathname to copy. */ - Tcl_DString *dstPtr, /* Destination pathname of copy. */ - int type, /* Reason for call - see TraverseWinTree() */ - Tcl_DString *errorPtr) /* If non-NULL, initialized DString filled - * with UTF-8 name of file causing error. */ -{ - TCHAR *nativeDst, *nativeSrc; - DWORD attr; - - switch (type) { - case DOTREE_F: { - if (DoCopyFile(srcPtr, dstPtr) == TCL_OK) { - return TCL_OK; - } - break; - } - case DOTREE_PRED: { - if (DoCreateDirectory(dstPtr) == TCL_OK) { - nativeSrc = (TCHAR *) Tcl_DStringValue(srcPtr); - nativeDst = (TCHAR *) Tcl_DStringValue(dstPtr); - attr = (*tclWinProcs->getFileAttributesProc)(nativeSrc); - if ((*tclWinProcs->setFileAttributesProc)(nativeDst, attr) != FALSE) { - return TCL_OK; - } - TclWinConvertError(GetLastError()); - } - break; - } - case DOTREE_POSTD: { - return TCL_OK; - } - } - - /* - * There shouldn't be a problem with src, because we already - * checked it to get here. - */ - - if (errorPtr != NULL) { - nativeDst = (TCHAR *) Tcl_DStringValue(dstPtr); - Tcl_WinTCharToUtf(nativeDst, -1, errorPtr); - } - return TCL_ERROR; -} - -/* - *---------------------------------------------------------------------- - * - * TraversalDelete -- - * - * Called by procedure TraverseWinTree for every file and - * directory that it encounters in a directory hierarchy. This - * procedure unlinks files, and removes directories after all the - * containing files have been processed. - * - * Results: - * Standard Tcl result. - * - * Side effects: - * Files or directory specified by src will be deleted. If an - * error occurs, the windows error is converted to a Posix error - * and errno is set accordingly. - * - *---------------------------------------------------------------------- - */ - -static int -TraversalDelete( - Tcl_DString *srcPtr, /* Source pathname to delete. */ - Tcl_DString *dstPtr, /* Not used. */ - int type, /* Reason for call - see TraverseWinTree() */ - Tcl_DString *errorPtr) /* If non-NULL, initialized DString filled - * with UTF-8 name of file causing error. */ -{ - TCHAR *nativeSrc; - - switch (type) { - case DOTREE_F: { - if (DoDeleteFile(srcPtr) == TCL_OK) { - return TCL_OK; - } - break; - } - case DOTREE_PRED: { - return TCL_OK; - } - case DOTREE_POSTD: { - if (DoRemoveDirectory(srcPtr, 0, NULL) == TCL_OK) { - return TCL_OK; - } - break; - } - } - - if (errorPtr != NULL) { - nativeSrc = (TCHAR *) Tcl_DStringValue(srcPtr); - Tcl_WinTCharToUtf(nativeSrc, -1, errorPtr); - } - return TCL_ERROR; -} - -/* - *---------------------------------------------------------------------- - * - * StatError -- - * - * Sets the object result with the appropriate error. - * - * Results: - * None. - * - * Side effects: - * The interp's object result is set with an error message - * based on the objIndex, fileName and errno. - * - *---------------------------------------------------------------------- - */ - -static void -StatError( - Tcl_Interp *interp, /* The interp that has the error */ - CONST char *fileName) /* The name of the file which caused the - * error. */ -{ - TclWinConvertError(GetLastError()); - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "could not read \"", fileName, "\": ", Tcl_PosixError(interp), - (char *) NULL); -} - -/* - *---------------------------------------------------------------------- - * - * GetWinFileAttributes -- - * - * Returns a Tcl_Obj containing the value of a file attribute. - * This routine gets the -hidden, -readonly or -system attribute. - * - * Results: - * Standard Tcl result and a Tcl_Obj in attributePtrPtr. The object - * will have ref count 0. If the return value is not TCL_OK, - * attributePtrPtr is not touched. - * - * Side effects: - * A new object is allocated if the file is valid. - * - *---------------------------------------------------------------------- - */ - -static int -GetWinFileAttributes( - Tcl_Interp *interp, /* The interp we are using for errors. */ - int objIndex, /* The index of the attribute. */ - CONST char *fileName, /* The name of the file. */ - Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */ -{ - DWORD result; - Tcl_DString ds; - TCHAR *nativeName; - - nativeName = Tcl_WinUtfToTChar(fileName, -1, &ds); - result = (*tclWinProcs->getFileAttributesProc)(nativeName); - Tcl_DStringFree(&ds); - - if (result == 0xffffffff) { - StatError(interp, fileName); - return TCL_ERROR; - } - - *attributePtrPtr = Tcl_NewBooleanObj((int) (result & attributeArray[objIndex])); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * ConvertFileNameFormat -- - * - * Returns a Tcl_Obj containing either the long or short version of the - * file name. - * - * Results: - * Standard Tcl result and a Tcl_Obj in attributePtrPtr. The object - * will have ref count 0. If the return value is not TCL_OK, - * attributePtrPtr is not touched. - * - * Side effects: - * A new object is allocated if the file is valid. - * - *---------------------------------------------------------------------- - */ - -static int -ConvertFileNameFormat( - Tcl_Interp *interp, /* The interp we are using for errors. */ - int objIndex, /* The index of the attribute. */ - CONST char *fileName, /* The name of the file. */ - int longShort, /* 0 to short name, 1 to long name. */ - Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */ -{ - int pathc, i; - char **pathv, **newv; - char *resultStr; - Tcl_DString resultDString; - int result = TCL_OK; - - Tcl_SplitPath(fileName, &pathc, &pathv); - newv = (char **) ckalloc(pathc * sizeof(char *)); - - if (pathc == 0) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "could not read \"", fileName, - "\": no such file or directory", - (char *) NULL); - result = TCL_ERROR; - goto cleanup; - } - - for (i = 0; i < pathc; i++) { - if ((pathv[i][0] == '/') - || ((strlen(pathv[i]) == 3) && (pathv[i][1] == ':')) - || (strcmp(pathv[i], ".") == 0) - || (strcmp(pathv[i], "..") == 0)) { - /* - * Handle "/", "//machine/export", "c:/", "." or ".." by just - * copying the string literally. Uppercase the drive letter, - * just because it looks better under Windows to do so. - */ - - simple: - pathv[i][0] = (char) Tcl_UniCharToUpper(UCHAR(pathv[i][0])); - newv[i] = (char *) ckalloc(strlen(pathv[i]) + 1); - lstrcpyA(newv[i], pathv[i]); - } else { - char *str; - TCHAR *nativeName; - Tcl_DString ds; - WIN32_FIND_DATAT data; - HANDLE handle; - DWORD attr; - - Tcl_DStringInit(&resultDString); - str = Tcl_JoinPath(i + 1, pathv, &resultDString); - nativeName = Tcl_WinUtfToTChar(str, -1, &ds); - handle = (*tclWinProcs->findFirstFileProc)(nativeName, &data); - if (handle == INVALID_HANDLE_VALUE) { - /* - * FindFirstFile() doesn't like root directories. We - * would only get a root directory here if the caller - * specified "c:" or "c:." and the current directory on the - * drive was the root directory - */ - - attr = (*tclWinProcs->getFileAttributesProc)(nativeName); - if ((attr != 0xFFFFFFFF) && (attr & FILE_ATTRIBUTE_DIRECTORY)) { - Tcl_DStringFree(&ds); - Tcl_DStringFree(&resultDString); - - goto simple; - } - } - Tcl_DStringFree(&ds); - Tcl_DStringFree(&resultDString); - - if (handle == INVALID_HANDLE_VALUE) { - pathc = i - 1; - StatError(interp, fileName); - result = TCL_ERROR; - goto cleanup; - } - if (tclWinProcs->useWide) { - nativeName = (TCHAR *) data.w.cAlternateFileName; - if (longShort) { - if (data.w.cFileName[0] != '\0') { - nativeName = (TCHAR *) data.w.cFileName; - } - } else { - if (data.w.cAlternateFileName[0] == '\0') { - nativeName = (TCHAR *) data.w.cFileName; - } - } - } else { - nativeName = (TCHAR *) data.a.cAlternateFileName; - if (longShort) { - if (data.a.cFileName[0] != '\0') { - nativeName = (TCHAR *) data.a.cFileName; - } - } else { - if (data.a.cAlternateFileName[0] == '\0') { - nativeName = (TCHAR *) data.a.cFileName; - } - } - } - - /* - * Purify reports a extraneous UMR in Tcl_WinTCharToUtf() trying - * to dereference nativeName as a Unicode string. I have proven - * to myself that purify is wrong by running the following - * example when nativeName == data.w.cAlternateFileName and - * noting that purify doesn't complain about the first line, - * but does complain about the second. - * - * fprintf(stderr, "%d\n", data.w.cAlternateFileName[0]); - * fprintf(stderr, "%d\n", ((WCHAR *) nativeName)[0]); - */ - - Tcl_WinTCharToUtf(nativeName, -1, &ds); - newv[i] = ckalloc((unsigned int) (Tcl_DStringLength(&ds) + 1)); - lstrcpyA(newv[i], Tcl_DStringValue(&ds)); - Tcl_DStringFree(&ds); - FindClose(handle); - } - } - - Tcl_DStringInit(&resultDString); - resultStr = Tcl_JoinPath(pathc, newv, &resultDString); - *attributePtrPtr = Tcl_NewStringObj(resultStr, - Tcl_DStringLength(&resultDString)); - Tcl_DStringFree(&resultDString); - -cleanup: - for (i = 0; i < pathc; i++) { - ckfree(newv[i]); - } - ckfree((char *) newv); - ckfree((char *) pathv); - return result; -} - -/* - *---------------------------------------------------------------------- - * - * GetWinFileLongName -- - * - * Returns a Tcl_Obj containing the short version of the file - * name. - * - * Results: - * Standard Tcl result and a Tcl_Obj in attributePtrPtr. The object - * will have ref count 0. If the return value is not TCL_OK, - * attributePtrPtr is not touched. - * - * Side effects: - * A new object is allocated if the file is valid. - * - *---------------------------------------------------------------------- - */ - -static int -GetWinFileLongName( - Tcl_Interp *interp, /* The interp we are using for errors. */ - int objIndex, /* The index of the attribute. */ - CONST char *fileName, /* The name of the file. */ - Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */ -{ - return ConvertFileNameFormat(interp, objIndex, fileName, 1, attributePtrPtr); -} - -/* - *---------------------------------------------------------------------- - * - * GetWinFileShortName -- - * - * Returns a Tcl_Obj containing the short version of the file - * name. - * - * Results: - * Standard Tcl result and a Tcl_Obj in attributePtrPtr. The object - * will have ref count 0. If the return value is not TCL_OK, - * attributePtrPtr is not touched. - * - * Side effects: - * A new object is allocated if the file is valid. - * - *---------------------------------------------------------------------- - */ - -static int -GetWinFileShortName( - Tcl_Interp *interp, /* The interp we are using for errors. */ - int objIndex, /* The index of the attribute. */ - CONST char *fileName, /* The name of the file. */ - Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */ -{ - return ConvertFileNameFormat(interp, objIndex, fileName, 0, attributePtrPtr); -} - -/* - *---------------------------------------------------------------------- - * - * SetWinFileAttributes -- - * - * Set the file attributes to the value given by attributePtr. - * This routine sets the -hidden, -readonly, or -system attributes. - * - * Results: - * Standard TCL error. - * - * Side effects: - * The file's attribute is set. - * - *---------------------------------------------------------------------- - */ - -static int -SetWinFileAttributes( - Tcl_Interp *interp, /* The interp we are using for errors. */ - int objIndex, /* The index of the attribute. */ - CONST char *fileName, /* The name of the file. */ - Tcl_Obj *attributePtr) /* The new value of the attribute. */ -{ - DWORD fileAttributes; - int yesNo; - int result; - Tcl_DString ds; - TCHAR *nativeName; - - nativeName = Tcl_WinUtfToTChar(fileName, -1, &ds); - fileAttributes = (*tclWinProcs->getFileAttributesProc)(nativeName); - - if (fileAttributes == 0xffffffff) { - StatError(interp, fileName); - result = TCL_ERROR; - goto end; - } - - result = Tcl_GetBooleanFromObj(interp, attributePtr, &yesNo); - if (result != TCL_OK) { - goto end; - } - - if (yesNo) { - fileAttributes |= (attributeArray[objIndex]); - } else { - fileAttributes &= ~(attributeArray[objIndex]); - } - - if (!(*tclWinProcs->setFileAttributesProc)(nativeName, fileAttributes)) { - StatError(interp, fileName); - result = TCL_ERROR; - goto end; - } - - end: - Tcl_DStringFree(&ds); - - return result; -} - -/* - *---------------------------------------------------------------------- - * - * SetWinFileLongName -- - * - * The attribute in question is a readonly attribute and cannot - * be set. - * - * Results: - * TCL_ERROR - * - * Side effects: - * The object result is set to a pertinant error message. - * - *---------------------------------------------------------------------- - */ - -static int -CannotSetAttribute( - Tcl_Interp *interp, /* The interp we are using for errors. */ - int objIndex, /* The index of the attribute. */ - CONST char *fileName, /* The name of the file. */ - Tcl_Obj *attributePtr) /* The new value of the attribute. */ -{ - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "cannot set attribute \"", tclpFileAttrStrings[objIndex], - "\" for file \"", fileName, "\": attribute is readonly", - (char *) NULL); - return TCL_ERROR; -} - - -/* - *--------------------------------------------------------------------------- - * - * TclpListVolumes -- - * - * Lists the currently mounted volumes - * - * Results: - * A standard Tcl result. Will always be TCL_OK, since there is no way - * that this command can fail. Also, the interpreter's result is set to - * the list of volumes. - * - * Side effects: - * None - * - *--------------------------------------------------------------------------- - */ - -int -TclpListVolumes( - Tcl_Interp *interp) /* Interpreter for returning volume list. */ -{ - Tcl_Obj *resultPtr, *elemPtr; - char buf[40 * 4]; /* There couldn't be more than 30 drives??? */ - int i; - char *p; - - resultPtr = Tcl_GetObjResult(interp); - - /* - * On Win32s: - * GetLogicalDriveStrings() isn't implemented. - * GetLogicalDrives() returns incorrect information. - */ - - if (GetLogicalDriveStringsA(sizeof(buf), buf) == 0) { - /* - * GetVolumeInformation() will detects all drives, but causes - * chattering on empty floppy drives. We only do this if - * GetLogicalDriveStrings() didn't work. It has also been reported - * that on some laptops it takes a while for GetVolumeInformation() - * to return when pinging an empty floppy drive, another reason to - * try to avoid calling it. - */ - - buf[1] = ':'; - buf[2] = '/'; - buf[3] = '\0'; - - for (i = 0; i < 26; i++) { - buf[0] = (char) ('a' + i); - if (GetVolumeInformationA(buf, NULL, 0, NULL, NULL, NULL, NULL, 0) - || (GetLastError() == ERROR_NOT_READY)) { - elemPtr = Tcl_NewStringObj(buf, -1); - Tcl_ListObjAppendElement(NULL, resultPtr, elemPtr); - } - } - } else { - for (p = buf; *p != '\0'; p += 4) { - p[2] = '/'; - elemPtr = Tcl_NewStringObj(p, -1); - Tcl_ListObjAppendElement(NULL, resultPtr, elemPtr); - } - } - return TCL_OK; -} diff --git a/win/tclWinFile.c b/win/tclWinFile.c deleted file mode 100644 index 1a689ac..0000000 --- a/win/tclWinFile.c +++ /dev/null @@ -1,1034 +0,0 @@ -/* - * tclWinFile.c -- - * - * This file contains temporary wrappers around UNIX file handling - * functions. These wrappers map the UNIX functions to Win32 HANDLE-style - * files, which can be manipulated through the Win32 console redirection - * interfaces. - * - * Copyright (c) 1995-1998 Sun Microsystems, Inc. - * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclWinFile.c,v 1.7 1999/12/12 22:46:51 hobbs Exp $ - */ - -#include "tclWinInt.h" -#include <sys/stat.h> -#include <shlobj.h> -#include <lmaccess.h> /* For TclpGetUserHome(). */ - -static time_t ToCTime(FILETIME fileTime); - -typedef NET_API_STATUS NET_API_FUNCTION NETUSERGETINFOPROC - (LPWSTR servername, LPWSTR username, DWORD level, LPBYTE *bufptr); - -typedef NET_API_STATUS NET_API_FUNCTION NETAPIBUFFERFREEPROC - (LPVOID Buffer); - -typedef NET_API_STATUS NET_API_FUNCTION NETGETDCNAMEPROC - (LPWSTR servername, LPWSTR domainname, LPBYTE *bufptr); - - -/* - *--------------------------------------------------------------------------- - * - * TclpFindExecutable -- - * - * This procedure computes the absolute path name of the current - * application, given its argv[0] value. - * - * Results: - * A dirty UTF string that is the path to the executable. At this - * point we may not know the system encoding. Convert the native - * string value to UTF using the default encoding. The assumption - * is that we will still be able to parse the path given the path - * name contains ASCII string and '/' chars do not conflict with - * other UTF chars. - * - * Side effects: - * The variable tclNativeExecutableName gets filled in with the file - * name for the application, if we figured it out. If we couldn't - * figure it out, tclNativeExecutableName is set to NULL. - * - *--------------------------------------------------------------------------- - */ - -char * -TclpFindExecutable(argv0) - CONST char *argv0; /* The value of the application's argv[0] - * (native). */ -{ - Tcl_DString ds; - WCHAR wName[MAX_PATH]; - - if (argv0 == NULL) { - return NULL; - } - if (tclNativeExecutableName != NULL) { - return tclNativeExecutableName; - } - - /* - * Under Windows we ignore argv0, and return the path for the file used to - * create this process. - */ - - (*tclWinProcs->getModuleFileNameProc)(NULL, wName, MAX_PATH); - Tcl_WinTCharToUtf((TCHAR *) wName, -1, &ds); - - tclNativeExecutableName = ckalloc((unsigned) (Tcl_DStringLength(&ds) + 1)); - strcpy(tclNativeExecutableName, Tcl_DStringValue(&ds)); - Tcl_DStringFree(&ds); - - TclWinNoBackslash(tclNativeExecutableName); - return tclNativeExecutableName; -} - -/* - *---------------------------------------------------------------------- - * - * TclpMatchFilesTypes -- - * - * This routine is used by the globbing code to search a - * directory for all files which match a given pattern. - * - * Results: - * If the tail argument is NULL, then the matching files are - * added to the the interp's result. Otherwise, TclDoGlob is called - * recursively for each matching subdirectory. The return value - * is a standard Tcl result indicating whether an error occurred - * in globbing. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- */ - -int -TclpMatchFilesTypes( - Tcl_Interp *interp, /* Interpreter to receive results. */ - char *separators, /* Directory separators to pass to TclDoGlob. */ - Tcl_DString *dirPtr, /* Contains path to directory to search. */ - char *pattern, /* Pattern to match against. */ - char *tail, /* Pointer to end of pattern. Tail must - * point to a location in pattern and must - * not be static.*/ - GlobTypeData *types) /* Object containing list of acceptable types. - * May be NULL. */ -{ - char drivePat[] = "?:\\"; - const char *message; - char *dir, *newPattern, *root; - int matchDotFiles; - int dirLength, result = TCL_OK; - Tcl_DString dirString, patternString; - DWORD attr, volFlags; - HANDLE handle; - WIN32_FIND_DATAT data; - BOOL found; - Tcl_DString ds; - TCHAR *nativeName; - Tcl_Obj *resultPtr; - - /* - * Convert the path to normalized form since some interfaces only - * accept backslashes. Also, ensure that the directory ends with a - * separator character. - */ - - dirLength = Tcl_DStringLength(dirPtr); - Tcl_DStringInit(&dirString); - if (dirLength == 0) { - Tcl_DStringAppend(&dirString, ".\\", 2); - } else { - char *p; - - Tcl_DStringAppend(&dirString, Tcl_DStringValue(dirPtr), - Tcl_DStringLength(dirPtr)); - for (p = Tcl_DStringValue(&dirString); *p != '\0'; p++) { - if (*p == '/') { - *p = '\\'; - } - } - p--; - if ((*p != '\\') && (*p != ':')) { - Tcl_DStringAppend(&dirString, "\\", 1); - } - } - dir = Tcl_DStringValue(&dirString); - - /* - * First verify that the specified path is actually a directory. - */ - - nativeName = Tcl_WinUtfToTChar(dir, Tcl_DStringLength(&dirString), &ds); - attr = (*tclWinProcs->getFileAttributesProc)(nativeName); - Tcl_DStringFree(&ds); - - if ((attr == 0xffffffff) || ((attr & FILE_ATTRIBUTE_DIRECTORY) == 0)) { - Tcl_DStringFree(&dirString); - return TCL_OK; - } - - /* - * Next check the volume information for the directory to see whether - * comparisons should be case sensitive or not. If the root is null, then - * we use the root of the current directory. If the root is just a drive - * specifier, we use the root directory of the given drive. - */ - - switch (Tcl_GetPathType(dir)) { - case TCL_PATH_RELATIVE: - found = GetVolumeInformationA(NULL, NULL, 0, NULL, NULL, - &volFlags, NULL, 0); - break; - case TCL_PATH_VOLUME_RELATIVE: - if (dir[0] == '\\') { - root = NULL; - } else { - root = drivePat; - *root = dir[0]; - } - found = GetVolumeInformationA(root, NULL, 0, NULL, NULL, - &volFlags, NULL, 0); - break; - case TCL_PATH_ABSOLUTE: - if (dir[1] == ':') { - root = drivePat; - *root = dir[0]; - found = GetVolumeInformationA(root, NULL, 0, NULL, NULL, - &volFlags, NULL, 0); - } else if (dir[1] == '\\') { - char *p; - - p = strchr(dir + 2, '\\'); - p = strchr(p + 1, '\\'); - p++; - nativeName = Tcl_WinUtfToTChar(dir, p - dir, &ds); - found = (*tclWinProcs->getVolumeInformationProc)(nativeName, - NULL, 0, NULL, NULL, &volFlags, NULL, 0); - Tcl_DStringFree(&ds); - } - break; - } - - if (found == 0) { - message = "couldn't read volume information for \""; - goto error; - } - - /* - * In Windows, although some volumes may support case sensitivity, Windows - * doesn't honor case. So in globbing we need to ignore the case - * of file names. - */ - - Tcl_DStringInit(&patternString); - newPattern = Tcl_DStringAppend(&patternString, pattern, tail - pattern); - Tcl_UtfToLower(newPattern); - - /* - * We need to check all files in the directory, so append a *.* - * to the path. - */ - - dir = Tcl_DStringAppend(&dirString, "*.*", 3); - nativeName = Tcl_WinUtfToTChar(dir, -1, &ds); - handle = (*tclWinProcs->findFirstFileProc)(nativeName, &data); - Tcl_DStringFree(&ds); - - if (handle == INVALID_HANDLE_VALUE) { - message = "couldn't read directory \""; - goto error; - } - - /* - * Clean up the tail pointer. Leave the tail pointing to the - * first character after the path separator or NULL. - */ - - if (*tail == '\\') { - tail++; - } - if (*tail == '\0') { - tail = NULL; - } else { - tail++; - } - - /* - * Check to see if the pattern needs to compare with dot files. - */ - - if ((newPattern[0] == '.') - || ((pattern[0] == '\\') && (pattern[1] == '.'))) { - matchDotFiles = 1; - } else { - matchDotFiles = 0; - } - - /* - * Now iterate over all of the files in the directory. - */ - - resultPtr = Tcl_GetObjResult(interp); - for (found = 1; found != 0; - found = (*tclWinProcs->findNextFileProc)(handle, &data)) { - TCHAR *nativeMatchResult; - char *name, *fname; - - if (tclWinProcs->useWide) { - nativeName = (TCHAR *) data.w.cFileName; - } else { - nativeName = (TCHAR *) data.a.cFileName; - } - name = Tcl_WinTCharToUtf(nativeName, -1, &ds); - - /* - * Check to see if the file matches the pattern. We need to convert - * the file name to lower case for comparison purposes. Note that we - * are ignoring the case sensitivity flag because Windows doesn't honor - * case even if the volume is case sensitive. If the volume also - * doesn't preserve case, then we previously returned the lower case - * form of the name. This didn't seem quite right since there are - * non-case-preserving volumes that actually return mixed case. So now - * we are returning exactly what we get from the system. - */ - - Tcl_UtfToLower(name); - nativeMatchResult = NULL; - - if ((matchDotFiles == 0) && (name[0] == '.')) { - /* - * Ignore hidden files. - */ - } else if (Tcl_StringMatch(name, newPattern) != 0) { - nativeMatchResult = nativeName; - } - Tcl_DStringFree(&ds); - - if (nativeMatchResult == NULL) { - continue; - } - - /* - * If the file matches, then we need to process the remainder of the - * path. If there are more characters to process, then ensure matching - * files are directories and call TclDoGlob. Otherwise, just add the - * file to the result. - */ - - name = Tcl_WinTCharToUtf(nativeMatchResult, -1, &ds); - Tcl_DStringAppend(dirPtr, name, -1); - Tcl_DStringFree(&ds); - - fname = Tcl_DStringValue(dirPtr); - nativeName = Tcl_WinUtfToTChar(fname, Tcl_DStringLength(dirPtr), &ds); - attr = (*tclWinProcs->getFileAttributesProc)(nativeName); - Tcl_DStringFree(&ds); - - if (tail == NULL) { - int typeOk = 1; - if (types != NULL) { - if (types->perm != 0) { - if ( - ((types->perm & TCL_GLOB_PERM_RONLY) && - !(attr & FILE_ATTRIBUTE_READONLY)) || - ((types->perm & TCL_GLOB_PERM_HIDDEN) && - !(attr & FILE_ATTRIBUTE_HIDDEN)) || - ((types->perm & TCL_GLOB_PERM_R) && - (TclpAccess(fname, R_OK) != 0)) || - ((types->perm & TCL_GLOB_PERM_W) && - (TclpAccess(fname, W_OK) != 0)) || - ((types->perm & TCL_GLOB_PERM_X) && - (TclpAccess(fname, X_OK) != 0)) - ) { - typeOk = 0; - } - } - if (typeOk && types->type != 0) { - struct stat buf; - /* - * We must match at least one flag to be listed - */ - typeOk = 0; - if (TclpLstat(fname, &buf) >= 0) { - /* - * In order bcdpfls as in 'find -t' - */ - if ( - ((types->type & TCL_GLOB_TYPE_BLOCK) && - S_ISBLK(buf.st_mode)) || - ((types->type & TCL_GLOB_TYPE_CHAR) && - S_ISCHR(buf.st_mode)) || - ((types->type & TCL_GLOB_TYPE_DIR) && - S_ISDIR(buf.st_mode)) || - ((types->type & TCL_GLOB_TYPE_PIPE) && - S_ISFIFO(buf.st_mode)) || - ((types->type & TCL_GLOB_TYPE_FILE) && - S_ISREG(buf.st_mode)) -#ifdef S_ISLNK - || ((types->type & TCL_GLOB_TYPE_LINK) && - S_ISLNK(buf.st_mode)) -#endif -#ifdef S_ISSOCK - || ((types->type & TCL_GLOB_TYPE_SOCK) && - S_ISSOCK(buf.st_mode)) -#endif - ) { - typeOk = 1; - } - } else { - /* Posix error occurred */ - } - } - } - if (typeOk) { - Tcl_ListObjAppendElement(interp, resultPtr, - Tcl_NewStringObj(fname, Tcl_DStringLength(dirPtr))); - } - } else if (attr & FILE_ATTRIBUTE_DIRECTORY) { - Tcl_DStringAppend(dirPtr, "/", 1); - result = TclDoGlob(interp, separators, dirPtr, tail, types); - if (result != TCL_OK) { - break; - } - } - Tcl_DStringSetLength(dirPtr, dirLength); - } - - FindClose(handle); - Tcl_DStringFree(&dirString); - Tcl_DStringFree(&patternString); - - return result; - - error: - Tcl_DStringFree(&dirString); - TclWinConvertError(GetLastError()); - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, message, Tcl_DStringValue(dirPtr), "\": ", - Tcl_PosixError(interp), (char *) NULL); - return TCL_ERROR; -} - -/* - * TclpMatchFiles -- - * - * This function is now obsolete. Call the above function - * 'TclpMatchFilesTypes' instead. - */ -int -TclpMatchFiles( - Tcl_Interp *interp, /* Interpreter to receive results. */ - char *separators, /* Directory separators to pass to TclDoGlob. */ - Tcl_DString *dirPtr, /* Contains path to directory to search. */ - char *pattern, /* Pattern to match against. */ - char *tail) /* Pointer to end of pattern. Tail must - * point to a location in pattern and must - * not be static.*/ -{ - return TclpMatchFilesTypes(interp,separators,dirPtr,pattern,tail,NULL); -} - -/* - *---------------------------------------------------------------------- - * - * TclpGetUserHome -- - * - * This function takes the passed in user name and finds the - * corresponding home directory specified in the password file. - * - * Results: - * The result is a pointer to a string specifying the user's home - * directory, or NULL if the user's home directory could not be - * determined. Storage for the result string is allocated in - * bufferPtr; the caller must call Tcl_DStringFree() when the result - * is no longer needed. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -char * -TclpGetUserHome(name, bufferPtr) - CONST char *name; /* User name for desired home directory. */ - Tcl_DString *bufferPtr; /* Uninitialized or free DString filled - * with name of user's home directory. */ -{ - char *result; - HINSTANCE netapiInst; - - result = NULL; - - Tcl_DStringInit(bufferPtr); - - netapiInst = LoadLibraryA("netapi32.dll"); - if (netapiInst != NULL) { - NETAPIBUFFERFREEPROC *netApiBufferFreeProc; - NETGETDCNAMEPROC *netGetDCNameProc; - NETUSERGETINFOPROC *netUserGetInfoProc; - - netApiBufferFreeProc = (NETAPIBUFFERFREEPROC *) - GetProcAddress(netapiInst, "NetApiBufferFree"); - netGetDCNameProc = (NETGETDCNAMEPROC *) - GetProcAddress(netapiInst, "NetGetDCName"); - netUserGetInfoProc = (NETUSERGETINFOPROC *) - GetProcAddress(netapiInst, "NetUserGetInfo"); - if ((netUserGetInfoProc != NULL) && (netGetDCNameProc != NULL) - && (netApiBufferFreeProc != NULL)) { - USER_INFO_1 *uiPtr; - Tcl_DString ds; - int nameLen, badDomain; - char *domain; - WCHAR *wName, *wHomeDir, *wDomain; - WCHAR buf[MAX_PATH]; - - badDomain = 0; - nameLen = -1; - wDomain = NULL; - domain = strchr(name, '@'); - if (domain != NULL) { - Tcl_DStringInit(&ds); - wName = Tcl_UtfToUniCharDString(domain + 1, -1, &ds); - badDomain = (*netGetDCNameProc)(NULL, wName, - (LPBYTE *) &wDomain); - Tcl_DStringFree(&ds); - nameLen = domain - name; - } - if (badDomain == 0) { - Tcl_DStringInit(&ds); - wName = Tcl_UtfToUniCharDString(name, nameLen, &ds); - if ((*netUserGetInfoProc)(wDomain, wName, 1, - (LPBYTE *) &uiPtr) == 0) { - wHomeDir = uiPtr->usri1_home_dir; - if ((wHomeDir != NULL) && (wHomeDir[0] != L'\0')) { - Tcl_UniCharToUtfDString(wHomeDir, lstrlenW(wHomeDir), - bufferPtr); - } else { - /* - * User exists but has no home dir. Return - * "{Windows Drive}:/users/default". - */ - - GetWindowsDirectoryW(buf, MAX_PATH); - Tcl_UniCharToUtfDString(buf, 2, bufferPtr); - Tcl_DStringAppend(bufferPtr, "/users/default", -1); - } - result = Tcl_DStringValue(bufferPtr); - (*netApiBufferFreeProc)((void *) uiPtr); - } - Tcl_DStringFree(&ds); - } - if (wDomain != NULL) { - (*netApiBufferFreeProc)((void *) wDomain); - } - } - FreeLibrary(netapiInst); - } - if (result == NULL) { - /* - * Look in the "Password Lists" section of system.ini for the - * local user. There are also entries in that section that begin - * with a "*" character that are used by Windows for other - * purposes; ignore user names beginning with a "*". - */ - - char buf[MAX_PATH]; - - if (name[0] != '*') { - if (GetPrivateProfileStringA("Password Lists", name, "", buf, - MAX_PATH, "system.ini") > 0) { - /* - * User exists, but there is no such thing as a home - * directory in system.ini. Return "{Windows drive}:/". - */ - - GetWindowsDirectoryA(buf, MAX_PATH); - Tcl_DStringAppend(bufferPtr, buf, 3); - result = Tcl_DStringValue(bufferPtr); - } - } - } - - return result; -} - -/* - *--------------------------------------------------------------------------- - * - * TclpAccess -- - * - * This function replaces the library version of access(), fixing the - * following bugs: - * - * 1. access() returns that all files have execute permission. - * - * Results: - * See access documentation. - * - * Side effects: - * See access documentation. - * - *--------------------------------------------------------------------------- - */ - -int -TclpAccess( - CONST char *path, /* Path of file to access (UTF-8). */ - int mode) /* Permission setting. */ -{ - Tcl_DString ds; - TCHAR *nativePath; - DWORD attr; - - nativePath = Tcl_WinUtfToTChar(path, -1, &ds); - attr = (*tclWinProcs->getFileAttributesProc)(nativePath); - Tcl_DStringFree(&ds); - - if (attr == 0xffffffff) { - /* - * File doesn't exist. - */ - - TclWinConvertError(GetLastError()); - return -1; - } - - if ((mode & W_OK) && (attr & FILE_ATTRIBUTE_READONLY)) { - /* - * File is not writable. - */ - - Tcl_SetErrno(EACCES); - return -1; - } - - if (mode & X_OK) { - CONST char *p; - - if (attr & FILE_ATTRIBUTE_DIRECTORY) { - /* - * Directories are always executable. - */ - - return 0; - } - p = strrchr(path, '.'); - if (p != NULL) { - p++; - if ((stricmp(p, "exe") == 0) - || (stricmp(p, "com") == 0) - || (stricmp(p, "bat") == 0)) { - /* - * File that ends with .exe, .com, or .bat is executable. - */ - - return 0; - } - } - Tcl_SetErrno(EACCES); - return -1; - } - - return 0; -} - -/* - *---------------------------------------------------------------------- - * - * TclpChdir -- - * - * This function replaces the library version of chdir(). - * - * Results: - * See chdir() documentation. - * - * Side effects: - * See chdir() documentation. - * - *---------------------------------------------------------------------- - */ - -int -TclpChdir(path) - CONST char *path; /* Path to new working directory (UTF-8). */ -{ - int result; - Tcl_DString ds; - TCHAR *nativePath; - - nativePath = Tcl_WinUtfToTChar(path, -1, &ds); - result = (*tclWinProcs->setCurrentDirectoryProc)(nativePath); - Tcl_DStringFree(&ds); - - if (result == 0) { - TclWinConvertError(GetLastError()); - return -1; - } - return 0; -} - -/* - *---------------------------------------------------------------------- - * - * TclpGetCwd -- - * - * This function replaces the library version of getcwd(). - * - * Results: - * The result is a pointer to a string specifying the current - * directory, or NULL if the current directory could not be - * determined. If NULL is returned, an error message is left in the - * interp's result. Storage for the result string is allocated in - * bufferPtr; the caller must call Tcl_DStringFree() when the result - * is no longer needed. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -char * -TclpGetCwd(interp, bufferPtr) - Tcl_Interp *interp; /* If non-NULL, used for error reporting. */ - Tcl_DString *bufferPtr; /* Uninitialized or free DString filled - * with name of current directory. */ -{ - WCHAR buffer[MAX_PATH]; - char *p; - - if ((*tclWinProcs->getCurrentDirectoryProc)(MAX_PATH, buffer) == 0) { - TclWinConvertError(GetLastError()); - if (interp != NULL) { - Tcl_AppendResult(interp, - "error getting working directory name: ", - Tcl_PosixError(interp), (char *) NULL); - } - return NULL; - } - - /* - * Watch for the wierd Windows c:\\UNC syntax. - */ - - if (tclWinProcs->useWide) { - WCHAR *native; - - native = (WCHAR *) buffer; - if ((native[0] != '\0') && (native[1] == ':') - && (native[2] == '\\') && (native[3] == '\\')) { - native += 2; - } - Tcl_WinTCharToUtf((TCHAR *) native, -1, bufferPtr); - } else { - char *native; - - native = (char *) buffer; - if ((native[0] != '\0') && (native[1] == ':') - && (native[2] == '\\') && (native[3] == '\\')) { - native += 2; - } - Tcl_WinTCharToUtf((TCHAR *) native, -1, bufferPtr); - } - - /* - * Convert to forward slashes for easier use in scripts. - */ - - for (p = Tcl_DStringValue(bufferPtr); *p != '\0'; p++) { - if (*p == '\\') { - *p = '/'; - } - } - return Tcl_DStringValue(bufferPtr); -} - -/* - *---------------------------------------------------------------------- - * - * TclpStat -- - * - * This function replaces the library version of stat(), fixing - * the following bugs: - * - * 1. stat("c:") returns an error. - * 2. Borland stat() return time in GMT instead of localtime. - * 3. stat("\\server\mount") would return error. - * 4. Accepts slashes or backslashes. - * 5. st_dev and st_rdev were wrong for UNC paths. - * - * Results: - * See stat documentation. - * - * Side effects: - * See stat documentation. - * - *---------------------------------------------------------------------- - */ - -int -TclpStat(path, statPtr) - CONST char *path; /* Path of file to stat (UTF-8). */ - struct stat *statPtr; /* Filled with results of stat call. */ -{ - Tcl_DString ds; - TCHAR *nativePath; - WIN32_FIND_DATAT data; - HANDLE handle; - DWORD attr; - WCHAR nativeFullPath[MAX_PATH]; - TCHAR *nativePart; - char *p, *fullPath; - int dev, mode; - - /* - * Eliminate file names containing wildcard characters, or subsequent - * call to FindFirstFile() will expand them, matching some other file. - */ - - if (strpbrk(path, "?*") != NULL) { - Tcl_SetErrno(ENOENT); - return -1; - } - - nativePath = Tcl_WinUtfToTChar(path, -1, &ds); - handle = (*tclWinProcs->findFirstFileProc)(nativePath, &data); - if (handle == INVALID_HANDLE_VALUE) { - /* - * FindFirstFile() doesn't work on root directories, so call - * GetFileAttributes() to see if the specified file exists. - */ - - attr = (*tclWinProcs->getFileAttributesProc)(nativePath); - if (attr == 0xffffffff) { - Tcl_DStringFree(&ds); - Tcl_SetErrno(ENOENT); - return -1; - } - - /* - * Make up some fake information for this file. It has the - * correct file attributes and a time of 0. - */ - - memset(&data, 0, sizeof(data)); - data.a.dwFileAttributes = attr; - } else { - FindClose(handle); - } - - (*tclWinProcs->getFullPathNameProc)(nativePath, MAX_PATH, nativeFullPath, - &nativePart); - - Tcl_DStringFree(&ds); - fullPath = Tcl_WinTCharToUtf((TCHAR *) nativeFullPath, -1, &ds); - - dev = -1; - if ((fullPath[0] == '\\') && (fullPath[1] == '\\')) { - char *p; - DWORD dw; - TCHAR *nativeVol; - Tcl_DString volString; - - p = strchr(fullPath + 2, '\\'); - p = strchr(p + 1, '\\'); - if (p == NULL) { - /* - * Add terminating backslash to fullpath or - * GetVolumeInformation() won't work. - */ - - fullPath = Tcl_DStringAppend(&ds, "\\", 1); - p = fullPath + Tcl_DStringLength(&ds); - } else { - p++; - } - nativeVol = Tcl_WinUtfToTChar(fullPath, p - fullPath, &volString); - dw = (DWORD) -1; - (*tclWinProcs->getVolumeInformationProc)(nativeVol, NULL, 0, &dw, - NULL, NULL, NULL, 0); - /* - * GetFullPathName() turns special devices like "NUL" into "\\.\NUL", - * but GetVolumeInformation() returns failure for "\\.\NUL". This - * will cause "NUL" to get a drive number of -1, which makes about - * as much sense as anything since the special devices don't live on - * any drive. - */ - - dev = dw; - Tcl_DStringFree(&volString); - } else if ((fullPath[0] != '\0') && (fullPath[1] == ':')) { - dev = Tcl_UniCharToLower(fullPath[0]) - 'a'; - } - Tcl_DStringFree(&ds); - - attr = data.a.dwFileAttributes; - mode = (attr & FILE_ATTRIBUTE_DIRECTORY) ? S_IFDIR | S_IEXEC : S_IFREG; - mode |= (attr & FILE_ATTRIBUTE_READONLY) ? S_IREAD : S_IREAD | S_IWRITE; - p = strrchr(path, '.'); - if (p != NULL) { - if ((lstrcmpiA(p, ".exe") == 0) - || (lstrcmpiA(p, ".com") == 0) - || (lstrcmpiA(p, ".bat") == 0) - || (lstrcmpiA(p, ".pif") == 0)) { - mode |= S_IEXEC; - } - } - - /* - * Propagate the S_IREAD, S_IWRITE, S_IEXEC bits to the group and - * other positions. - */ - - mode |= (mode & 0x0700) >> 3; - mode |= (mode & 0x0700) >> 6; - - statPtr->st_dev = (dev_t) dev; - statPtr->st_ino = 0; - statPtr->st_mode = (unsigned short) mode; - statPtr->st_nlink = 1; - statPtr->st_uid = 0; - statPtr->st_gid = 0; - statPtr->st_rdev = (dev_t) dev; - statPtr->st_size = data.a.nFileSizeLow; - statPtr->st_atime = ToCTime(data.a.ftLastAccessTime); - statPtr->st_mtime = ToCTime(data.a.ftLastWriteTime); - statPtr->st_ctime = ToCTime(data.a.ftCreationTime); - return 0; -} - -static time_t -ToCTime( - FILETIME fileTime) /* UTC Time to convert to local time_t. */ -{ - FILETIME localFileTime; - SYSTEMTIME systemTime; - struct tm tm; - - if (FileTimeToLocalFileTime(&fileTime, &localFileTime) == 0) { - return 0; - } - if (FileTimeToSystemTime(&localFileTime, &systemTime) == 0) { - return 0; - } - tm.tm_sec = systemTime.wSecond; - tm.tm_min = systemTime.wMinute; - tm.tm_hour = systemTime.wHour; - tm.tm_mday = systemTime.wDay; - tm.tm_mon = systemTime.wMonth - 1; - tm.tm_year = systemTime.wYear - 1900; - tm.tm_wday = 0; - tm.tm_yday = 0; - tm.tm_isdst = -1; - - return mktime(&tm); -} - -#if 0 - - /* - * Borland's stat doesn't take into account localtime. - */ - - if ((result == 0) && (buf->st_mtime != 0)) { - TIME_ZONE_INFORMATION tz; - int time, bias; - - time = GetTimeZoneInformation(&tz); - bias = tz.Bias; - if (time == TIME_ZONE_ID_DAYLIGHT) { - bias += tz.DaylightBias; - } - bias *= 60; - buf->st_atime -= bias; - buf->st_ctime -= bias; - buf->st_mtime -= bias; - } - -#endif - - -#if 0 -/* - *------------------------------------------------------------------------- - * - * TclWinResolveShortcut -- - * - * Resolve a potential Windows shortcut to get the actual file or - * directory in question. - * - * Results: - * Returns 1 if the shortcut could be resolved, or 0 if there was - * an error or if the filename was not a shortcut. - * If bufferPtr did hold the name of a shortcut, it is modified to - * hold the resolved target of the shortcut instead. - * - * Side effects: - * Loads and unloads OLE package to determine if filename refers to - * a shortcut. - * - *------------------------------------------------------------------------- - */ - -int -TclWinResolveShortcut(bufferPtr) - Tcl_DString *bufferPtr; /* Holds name of file to resolve. On - * return, holds resolved file name. */ -{ - HRESULT hres; - IShellLink *psl; - IPersistFile *ppf; - WIN32_FIND_DATA wfd; - WCHAR wpath[MAX_PATH]; - char *path, *ext; - char realFileName[MAX_PATH]; - - /* - * Windows system calls do not automatically resolve - * shortcuts like UNIX automatically will with symbolic links. - */ - - path = Tcl_DStringValue(bufferPtr); - ext = strrchr(path, '.'); - if ((ext == NULL) || (stricmp(ext, ".lnk") != 0)) { - return 0; - } - - CoInitialize(NULL); - path = Tcl_DStringValue(bufferPtr); - realFileName[0] = '\0'; - hres = CoCreateInstance(&CLSID_ShellLink, NULL, CLSCTX_INPROC_SERVER, - &IID_IShellLink, &psl); - if (SUCCEEDED(hres)) { - hres = psl->lpVtbl->QueryInterface(psl, &IID_IPersistFile, &ppf); - if (SUCCEEDED(hres)) { - MultiByteToWideChar(CP_ACP, 0, path, -1, wpath, sizeof(wpath)); - hres = ppf->lpVtbl->Load(ppf, wpath, STGM_READ); - if (SUCCEEDED(hres)) { - hres = psl->lpVtbl->Resolve(psl, NULL, - SLR_ANY_MATCH | SLR_NO_UI); - if (SUCCEEDED(hres)) { - hres = psl->lpVtbl->GetPath(psl, realFileName, MAX_PATH, - &wfd, 0); - } - } - ppf->lpVtbl->Release(ppf); - } - psl->lpVtbl->Release(psl); - } - CoUninitialize(); - - if (realFileName[0] != '\0') { - Tcl_DStringSetLength(bufferPtr, 0); - Tcl_DStringAppend(bufferPtr, realFileName, -1); - return 1; - } - return 0; -} -#endif diff --git a/win/tclWinInit.c b/win/tclWinInit.c deleted file mode 100644 index dbf44ea..0000000 --- a/win/tclWinInit.c +++ /dev/null @@ -1,845 +0,0 @@ -/* - * tclWinInit.c -- - * - * Contains the Windows-specific interpreter initialization functions. - * - * Copyright (c) 1994-1997 Sun Microsystems, Inc. - * Copyright (c) 1998-1999 by Scriptics Corporation. - * All rights reserved. - * - * RCS: @(#) $Id: tclWinInit.c,v 1.22 2000/03/31 08:52:31 hobbs Exp $ - */ - -#include "tclWinInt.h" -#include <winreg.h> -#include <winnt.h> -#include <winbase.h> - -/* - * The following macro can be defined at compile time to specify - * the root of the Tcl registry keys. - */ - -#ifndef TCL_REGISTRY_KEY -#define TCL_REGISTRY_KEY "Software\\Scriptics\\Tcl\\" TCL_VERSION -#endif - -/* - * The following declaration is a workaround for some Microsoft brain damage. - * The SYSTEM_INFO structure is different in various releases, even though the - * layout is the same. So we overlay our own structure on top of it so we - * can access the interesting slots in a uniform way. - */ - -typedef struct { - WORD wProcessorArchitecture; - WORD wReserved; -} OemId; - -/* - * The following macros are missing from some versions of winnt.h. - */ - -#ifndef PROCESSOR_ARCHITECTURE_INTEL -#define PROCESSOR_ARCHITECTURE_INTEL 0 -#endif -#ifndef PROCESSOR_ARCHITECTURE_MIPS -#define PROCESSOR_ARCHITECTURE_MIPS 1 -#endif -#ifndef PROCESSOR_ARCHITECTURE_ALPHA -#define PROCESSOR_ARCHITECTURE_ALPHA 2 -#endif -#ifndef PROCESSOR_ARCHITECTURE_PPC -#define PROCESSOR_ARCHITECTURE_PPC 3 -#endif -#ifndef PROCESSOR_ARCHITECTURE_UNKNOWN -#define PROCESSOR_ARCHITECTURE_UNKNOWN 0xFFFF -#endif - -/* - * The following arrays contain the human readable strings for the Windows - * platform and processor values. - */ - - -#define NUMPLATFORMS 3 -static char* platforms[NUMPLATFORMS] = { - "Win32s", "Windows 95", "Windows NT" -}; - -#define NUMPROCESSORS 4 -static char* processors[NUMPROCESSORS] = { - "intel", "mips", "alpha", "ppc" -}; - -/* - * Thread id used for asynchronous notification from signal handlers. - */ - -static DWORD mainThreadId; - -/* - * The Init script (common to Windows and Unix platforms) is - * defined in tkInitScript.h - */ - -#include "tclInitScript.h" - -static void AppendEnvironment(Tcl_Obj *listPtr, CONST char *lib); -static void AppendDllPath(Tcl_Obj *listPtr, HMODULE hModule, - CONST char *lib); -static void AppendRegistry(Tcl_Obj *listPtr, CONST char *lib); -static int ToUtf(CONST WCHAR *wSrc, char *dst); - -/* - *--------------------------------------------------------------------------- - * - * TclpInitPlatform -- - * - * Initialize all the platform-dependant things like signals and - * floating-point error handling. - * - * Called at process initialization time. - * - * Results: - * None. - * - * Side effects: - * None. - * - *--------------------------------------------------------------------------- - */ - -void -TclpInitPlatform() -{ - tclPlatform = TCL_PLATFORM_WINDOWS; - - /* - * The following code stops Windows 3.X and Windows NT 3.51 from - * automatically putting up Sharing Violation dialogs, e.g, when - * someone tries to access a file that is locked or a drive with no - * disk in it. Tcl already returns the appropriate error to the - * caller, and they can decide to put up their own dialog in response - * to that failure. - * - * Under 95 and NT 4.0, this is a NOOP because the system doesn't - * automatically put up dialogs when the above operations fail. - */ - - SetErrorMode(SetErrorMode(0) | SEM_FAILCRITICALERRORS); - - /* - * Save the id of the first thread to intialize the Tcl library. This - * thread will be used to handle notifications from async event - * procedures. This is not strictly correct. A better solution involves - * using a designated "main" notifier that is kept up to date as threads - * come and go. - */ - - mainThreadId = GetCurrentThreadId(); - -#ifdef STATIC_BUILD - /* - * If we are in a statically linked executable, then we need to - * explicitly initialize the Windows function tables here since - * DllMain() will not be invoked. - */ - - TclWinInit(GetModuleHandle(NULL)); -#endif -} - -/* - *--------------------------------------------------------------------------- - * - * TclpInitLibraryPath -- - * - * Initialize the library path at startup. - * - * This call sets the library path to strings in UTF-8. Any - * pre-existing library path information is assumed to have been - * in the native multibyte encoding. - * - * Called at process initialization time. - * - * Results: - * None. - * - * Side effects: - * None. - * - *--------------------------------------------------------------------------- - */ - -void -TclpInitLibraryPath(path) - CONST char *path; /* Potentially dirty UTF string that is */ - /* the path to the executable name. */ -{ -#define LIBRARY_SIZE 32 - Tcl_Obj *pathPtr, *objPtr; - char *str; - Tcl_DString ds; - int pathc; - char **pathv; - char installLib[LIBRARY_SIZE], developLib[LIBRARY_SIZE]; - - Tcl_DStringInit(&ds); - pathPtr = Tcl_NewObj(); - - /* - * Initialize the substrings used when locating an executable. The - * installLib variable computes the path as though the executable - * is installed. The developLib computes the path as though the - * executable is run from a develpment directory. - */ - - sprintf(installLib, "lib/tcl%s", TCL_VERSION); - sprintf(developLib, "../tcl%s/library", - ((TCL_RELEASE_LEVEL < 2) ? TCL_PATCH_LEVEL : TCL_VERSION)); - - /* - * Look for the library relative to default encoding dir. - */ - - str = Tcl_GetDefaultEncodingDir(); - if ((str != NULL) && (str[0] != '\0')) { - objPtr = Tcl_NewStringObj(str, -1); - Tcl_ListObjAppendElement(NULL, pathPtr, objPtr); - } - - /* - * Look for the library relative to the TCL_LIBRARY env variable. - * If the last dirname in the TCL_LIBRARY path does not match the - * last dirname in the installLib variable, use the last dir name - * of installLib in addition to the orginal TCL_LIBRARY path. - */ - - AppendEnvironment(pathPtr, installLib); - - /* - * Look for the library relative to the DLL. Only use the installLib - * because in practice, the DLL is always installed. - */ - - AppendDllPath(pathPtr, TclWinGetTclInstance(), installLib); - - - /* - * Look for the library relative to the executable. This algorithm - * should be the same as the one in the tcl_findLibrary procedure. - * - * This code looks in the following directories: - * - * <bindir>/../<installLib> - * (e.g. /usr/local/bin/../lib/tcl8.2) - * <bindir>/../../<installLib> - * (e.g. /usr/local/TclPro/solaris-sparc/bin/../../lib/tcl8.2) - * <bindir>/../library - * (e.g. /usr/src/tcl8.2/unix/../library) - * <bindir>/../../library - * (e.g. /usr/src/tcl8.2/unix/solaris-sparc/../../library) - * <bindir>/../../<developLib> - * (e.g. /usr/src/tcl8.2/unix/../../tcl8.2/library) - * <bindir>/../../../<devlopLib> - * (e.g. /usr/src/tcl8.2/unix/solaris-sparc/../../../tcl8.2/library) - */ - - if (path != NULL) { - Tcl_SplitPath(path, &pathc, &pathv); - if (pathc > 1) { - pathv[pathc - 2] = installLib; - path = Tcl_JoinPath(pathc - 1, pathv, &ds); - objPtr = Tcl_NewStringObj(path, Tcl_DStringLength(&ds)); - Tcl_ListObjAppendElement(NULL, pathPtr, objPtr); - Tcl_DStringFree(&ds); - } - if (pathc > 2) { - pathv[pathc - 3] = installLib; - path = Tcl_JoinPath(pathc - 2, pathv, &ds); - objPtr = Tcl_NewStringObj(path, Tcl_DStringLength(&ds)); - Tcl_ListObjAppendElement(NULL, pathPtr, objPtr); - Tcl_DStringFree(&ds); - } - if (pathc > 1) { - pathv[pathc - 2] = "library"; - path = Tcl_JoinPath(pathc - 1, pathv, &ds); - objPtr = Tcl_NewStringObj(path, Tcl_DStringLength(&ds)); - Tcl_ListObjAppendElement(NULL, pathPtr, objPtr); - Tcl_DStringFree(&ds); - } - if (pathc > 2) { - pathv[pathc - 3] = "library"; - path = Tcl_JoinPath(pathc - 2, pathv, &ds); - objPtr = Tcl_NewStringObj(path, Tcl_DStringLength(&ds)); - Tcl_ListObjAppendElement(NULL, pathPtr, objPtr); - Tcl_DStringFree(&ds); - } - if (pathc > 1) { - pathv[pathc - 3] = developLib; - path = Tcl_JoinPath(pathc - 2, pathv, &ds); - objPtr = Tcl_NewStringObj(path, Tcl_DStringLength(&ds)); - Tcl_ListObjAppendElement(NULL, pathPtr, objPtr); - Tcl_DStringFree(&ds); - } - if (pathc > 3) { - pathv[pathc - 4] = developLib; - path = Tcl_JoinPath(pathc - 3, pathv, &ds); - objPtr = Tcl_NewStringObj(path, Tcl_DStringLength(&ds)); - Tcl_ListObjAppendElement(NULL, pathPtr, objPtr); - Tcl_DStringFree(&ds); - } - ckfree((char *) pathv); - } - - TclSetLibraryPath(pathPtr); -} - -/* - *--------------------------------------------------------------------------- - * - * AppendEnvironment -- - * - * Append the value of the TCL_LIBRARY environment variable onto the - * path pointer. If the env variable points to another version of - * tcl (e.g. "tcl7.6") also append the path to this version (e.g., - * "tcl7.6/../tcl8.2") - * - * Results: - * None. - * - * Side effects: - * None. - * - *--------------------------------------------------------------------------- - */ - -static void -AppendEnvironment( - Tcl_Obj *pathPtr, - CONST char *lib) -{ - int pathc; - WCHAR wBuf[MAX_PATH]; - char buf[MAX_PATH * TCL_UTF_MAX]; - Tcl_Obj *objPtr; - char *str; - Tcl_DString ds; - char **pathv; - - /* - * The "L" preceeding the TCL_LIBRARY string is used to tell VC++ - * that this is a unicode string. - */ - - if (GetEnvironmentVariableW(L"TCL_LIBRARY", wBuf, MAX_PATH) == 0) { - buf[0] = '\0'; - GetEnvironmentVariableA("TCL_LIBRARY", buf, MAX_PATH); - } else { - ToUtf(wBuf, buf); - } - - if (buf[0] != '\0') { - objPtr = Tcl_NewStringObj(buf, -1); - Tcl_ListObjAppendElement(NULL, pathPtr, objPtr); - - TclWinNoBackslash(buf); - Tcl_SplitPath(buf, &pathc, &pathv); - - /* - * The lstrcmpi() will work even if pathv[pathc - 1] is random - * UTF-8 chars because I know lib is ascii. - */ - - if ((pathc > 0) && (lstrcmpiA(lib + 4, pathv[pathc - 1]) != 0)) { - /* - * TCL_LIBRARY is set but refers to a different tcl - * installation than the current version. Try fiddling with the - * specified directory to make it refer to this installation by - * removing the old "tclX.Y" and substituting the current - * version string. - */ - - pathv[pathc - 1] = (char *) (lib + 4); - Tcl_DStringInit(&ds); - str = Tcl_JoinPath(pathc, pathv, &ds); - objPtr = Tcl_NewStringObj(str, Tcl_DStringLength(&ds)); - Tcl_DStringFree(&ds); - } else { - objPtr = Tcl_NewStringObj(buf, -1); - } - Tcl_ListObjAppendElement(NULL, pathPtr, objPtr); - ckfree((char *) pathv); - } -} - -/* - *--------------------------------------------------------------------------- - * - * AppendDllPath -- - * - * Append a path onto the path pointer that tries to locate the Tcl - * library relative to the location of the Tcl DLL. - * - * Results: - * None. - * - * Side effects: - * None. - * - *--------------------------------------------------------------------------- - */ - -static void -AppendDllPath( - Tcl_Obj *pathPtr, - HMODULE hModule, - CONST char *lib) -{ - WCHAR wName[MAX_PATH + LIBRARY_SIZE]; - char name[(MAX_PATH + LIBRARY_SIZE) * TCL_UTF_MAX]; - - if (GetModuleFileNameW(hModule, wName, MAX_PATH) == 0) { - GetModuleFileNameA(hModule, name, MAX_PATH); - } else { - ToUtf(wName, name); - } - if (lib != NULL) { - char *end, *p; - - end = strrchr(name, '\\'); - *end = '\0'; - p = strrchr(name, '\\'); - if (p != NULL) { - end = p; - } - *end = '\\'; - strcpy(end + 1, lib); - } - TclWinNoBackslash(name); - Tcl_ListObjAppendElement(NULL, pathPtr, Tcl_NewStringObj(name, -1)); -} - -/* - *--------------------------------------------------------------------------- - * - * ToUtf -- - * - * Convert a char string to a UTF string. - * - * Results: - * None. - * - * Side effects: - * None. - * - *--------------------------------------------------------------------------- - */ - -static int -ToUtf( - CONST WCHAR *wSrc, - char *dst) -{ - char *start; - - start = dst; - while (*wSrc != '\0') { - dst += Tcl_UniCharToUtf(*wSrc, dst); - wSrc++; - } - *dst = '\0'; - return dst - start; -} - - -/* - *--------------------------------------------------------------------------- - * - * TclpSetInitialEncodings -- - * - * Based on the locale, determine the encoding of the operating - * system and the default encoding for newly opened files. - * - * Called at process initialization time. - * - * Results: - * None. - * - * Side effects: - * The Tcl library path is converted from native encoding to UTF-8. - * - *--------------------------------------------------------------------------- - */ - -void -TclpSetInitialEncodings() -{ - CONST char *encoding; - char buf[4 + TCL_INTEGER_SPACE]; - int platformId; - Tcl_Obj *pathPtr; - - platformId = TclWinGetPlatformId(); - - TclWinSetInterfaces(platformId == VER_PLATFORM_WIN32_NT); - - wsprintfA(buf, "cp%d", GetACP()); - Tcl_SetSystemEncoding(NULL, buf); - - if (platformId != VER_PLATFORM_WIN32_NT) { - pathPtr = TclGetLibraryPath(); - if (pathPtr != NULL) { - int i, objc; - Tcl_Obj **objv; - - objc = 0; - Tcl_ListObjGetElements(NULL, pathPtr, &objc, &objv); - for (i = 0; i < objc; i++) { - int length; - char *string; - Tcl_DString ds; - - string = Tcl_GetStringFromObj(objv[i], &length); - Tcl_ExternalToUtfDString(NULL, string, length, &ds); - Tcl_SetStringObj(objv[i], Tcl_DStringValue(&ds), - Tcl_DStringLength(&ds)); - Tcl_DStringFree(&ds); - } - } - } - - /* - * Keep this encoding preloaded. The IO package uses it for gets on a - * binary channel. - */ - - encoding = "iso8859-1"; - Tcl_GetEncoding(NULL, encoding); -} - -/* - *--------------------------------------------------------------------------- - * - * TclpSetVariables -- - * - * Performs platform-specific interpreter initialization related to - * the tcl_platform and env variables, and other platform-specific - * things. - * - * Results: - * None. - * - * Side effects: - * Sets "tclDefaultLibrary", "tcl_platform", and "env(HOME)" Tcl - * variables. - * - *---------------------------------------------------------------------- - */ - -void -TclpSetVariables(interp) - Tcl_Interp *interp; /* Interp to initialize. */ -{ - char *ptr; - char buffer[TCL_INTEGER_SPACE * 2]; - SYSTEM_INFO sysInfo; - OemId *oemId; - OSVERSIONINFOA osInfo; - Tcl_DString ds; - - osInfo.dwOSVersionInfoSize = sizeof(OSVERSIONINFOA); - GetVersionExA(&osInfo); - - oemId = (OemId *) &sysInfo; - GetSystemInfo(&sysInfo); - - /* - * Initialize the tclDefaultLibrary variable from the registry. - */ - - Tcl_SetVar(interp, "tclDefaultLibrary", "", TCL_GLOBAL_ONLY); - - /* - * Define the tcl_platform array. - */ - - Tcl_SetVar2(interp, "tcl_platform", "platform", "windows", - TCL_GLOBAL_ONLY); - if (osInfo.dwPlatformId < NUMPLATFORMS) { - Tcl_SetVar2(interp, "tcl_platform", "os", - platforms[osInfo.dwPlatformId], TCL_GLOBAL_ONLY); - } - wsprintfA(buffer, "%d.%d", osInfo.dwMajorVersion, osInfo.dwMinorVersion); - Tcl_SetVar2(interp, "tcl_platform", "osVersion", buffer, TCL_GLOBAL_ONLY); - if (oemId->wProcessorArchitecture < NUMPROCESSORS) { - Tcl_SetVar2(interp, "tcl_platform", "machine", - processors[oemId->wProcessorArchitecture], - TCL_GLOBAL_ONLY); - } - -#ifdef _DEBUG - /* - * The existence of the "debug" element of the tcl_platform array indicates - * that this particular Tcl shell has been compiled with debug information. - * Using "info exists tcl_platform(debug)" a Tcl script can direct the - * interpreter to load debug versions of DLLs with the load command. - */ - - Tcl_SetVar2(interp, "tcl_platform", "debug", "1", - TCL_GLOBAL_ONLY); -#endif - - /* - * Set up the HOME environment variable from the HOMEDRIVE & HOMEPATH - * environment variables, if necessary. - */ - - Tcl_DStringInit(&ds); - ptr = Tcl_GetVar2(interp, "env", "HOME", TCL_GLOBAL_ONLY); - if (ptr == NULL) { - ptr = Tcl_GetVar2(interp, "env", "HOMEDRIVE", TCL_GLOBAL_ONLY); - if (ptr != NULL) { - Tcl_DStringAppend(&ds, ptr, -1); - } - ptr = Tcl_GetVar2(interp, "env", "HOMEPATH", TCL_GLOBAL_ONLY); - if (ptr != NULL) { - Tcl_DStringAppend(&ds, ptr, -1); - } - if (Tcl_DStringLength(&ds) > 0) { - Tcl_SetVar2(interp, "env", "HOME", Tcl_DStringValue(&ds), - TCL_GLOBAL_ONLY); - } else { - Tcl_SetVar2(interp, "env", "HOME", "c:\\", TCL_GLOBAL_ONLY); - } - } - - /* - * Initialize the user name from the environment first, since this is much - * faster than asking the system. - */ - - Tcl_DStringSetLength(&ds, 100); - if (TclGetEnv("USERNAME", &ds) == NULL) { - if (GetUserName(Tcl_DStringValue(&ds), &Tcl_DStringLength(&ds)) == 0) { - Tcl_DStringSetLength(&ds, 0); - } - } - Tcl_SetVar2(interp, "tcl_platform", "user", Tcl_DStringValue(&ds), - TCL_GLOBAL_ONLY); - Tcl_DStringFree(&ds); -} - -/* - *---------------------------------------------------------------------- - * - * TclpFindVariable -- - * - * Locate the entry in environ for a given name. On Unix this - * routine is case sensetive, on Windows this matches mioxed case. - * - * Results: - * The return value is the index in environ of an entry with the - * name "name", or -1 if there is no such entry. The integer at - * *lengthPtr is filled in with the length of name (if a matching - * entry is found) or the length of the environ array (if no matching - * entry is found). - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -TclpFindVariable(name, lengthPtr) - CONST char *name; /* Name of desired environment variable - * (UTF-8). */ - int *lengthPtr; /* Used to return length of name (for - * successful searches) or number of non-NULL - * entries in environ (for unsuccessful - * searches). */ -{ - int i, length, result = -1; - register CONST char *env, *p1, *p2; - char *envUpper, *nameUpper; - Tcl_DString envString; - - /* - * Convert the name to all upper case for the case insensitive - * comparison. - */ - - length = strlen(name); - nameUpper = (char *) ckalloc((unsigned) length+1); - memcpy((VOID *) nameUpper, (VOID *) name, (size_t) length+1); - Tcl_UtfToUpper(nameUpper); - - Tcl_DStringInit(&envString); - for (i = 0, env = environ[i]; env != NULL; i++, env = environ[i]) { - /* - * Chop the env string off after the equal sign, then Convert - * the name to all upper case, so we do not have to convert - * all the characters after the equal sign. - */ - - envUpper = Tcl_ExternalToUtfDString(NULL, env, -1, &envString); - p1 = strchr(envUpper, '='); - if (p1 == NULL) { - continue; - } - length = p1 - envUpper; - Tcl_DStringSetLength(&envString, length+1); - Tcl_UtfToUpper(envUpper); - - p1 = envUpper; - p2 = nameUpper; - for (; *p2 == *p1; p1++, p2++) { - /* NULL loop body. */ - } - if ((*p1 == '=') && (*p2 == '\0')) { - *lengthPtr = length; - result = i; - goto done; - } - - Tcl_DStringFree(&envString); - } - - *lengthPtr = i; - - done: - Tcl_DStringFree(&envString); - ckfree(nameUpper); - return result; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_Init -- - * - * This procedure is typically invoked by Tcl_AppInit procedures - * to perform additional initialization for a Tcl interpreter, - * such as sourcing the "init.tcl" script. - * - * Results: - * Returns a standard Tcl completion code and sets the interp's - * result if there is an error. - * - * Side effects: - * Depends on what's in the init.tcl script. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_Init(interp) - Tcl_Interp *interp; /* Interpreter to initialize. */ -{ - Tcl_Obj *pathPtr; - - if (tclPreInitScript != NULL) { - if (Tcl_Eval(interp, tclPreInitScript) == TCL_ERROR) { - return (TCL_ERROR); - }; - } - - pathPtr = TclGetLibraryPath(); - if (pathPtr == NULL) { - pathPtr = Tcl_NewObj(); - } - Tcl_SetVar2Ex(interp, "tcl_libPath", NULL, pathPtr, TCL_GLOBAL_ONLY); - return Tcl_Eval(interp, initScript); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_SourceRCFile -- - * - * This procedure is typically invoked by Tcl_Main of Tk_Main - * procedure to source an application specific rc file into the - * interpreter at startup time. - * - * Results: - * None. - * - * Side effects: - * Depends on what's in the rc script. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_SourceRCFile(interp) - Tcl_Interp *interp; /* Interpreter to source rc file into. */ -{ - Tcl_DString temp; - char *fileName; - Tcl_Channel errChannel; - - fileName = Tcl_GetVar(interp, "tcl_rcFileName", TCL_GLOBAL_ONLY); - - if (fileName != NULL) { - Tcl_Channel c; - char *fullName; - - Tcl_DStringInit(&temp); - fullName = Tcl_TranslateFileName(interp, fileName, &temp); - if (fullName == NULL) { - /* - * Couldn't translate the file name (e.g. it referred to a - * bogus user or there was no HOME environment variable). - * Just do nothing. - */ - } else { - - /* - * Test for the existence of the rc file before trying to read it. - */ - - c = Tcl_OpenFileChannel(NULL, fullName, "r", 0); - if (c != (Tcl_Channel) NULL) { - Tcl_Close(NULL, c); - if (Tcl_EvalFile(interp, fullName) != TCL_OK) { - errChannel = Tcl_GetStdChannel(TCL_STDERR); - if (errChannel) { - Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp)); - Tcl_WriteChars(errChannel, "\n", 1); - } - } - } - } - Tcl_DStringFree(&temp); - } -} - -/* - *---------------------------------------------------------------------- - * - * TclpAsyncMark -- - * - * Wake up the main thread from a signal handler. - * - * Results: - * None. - * - * Side effects: - * Sends a message to the main thread. - * - *---------------------------------------------------------------------- - */ - -void -TclpAsyncMark(async) - Tcl_AsyncHandler async; /* Token for handler. */ -{ - /* - * Need a way to kick the Windows event loop and tell it to go look at - * asynchronous events. - */ - - PostThreadMessage(mainThreadId, WM_USER, 0, 0); -} diff --git a/win/tclWinInt.h b/win/tclWinInt.h deleted file mode 100644 index b744045..0000000 --- a/win/tclWinInt.h +++ /dev/null @@ -1,109 +0,0 @@ -/* - * tclWinInt.h -- - * - * Declarations of Windows-specific shared variables and procedures. - * - * Copyright (c) 1994-1996 Sun Microsystems, Inc. - * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclWinInt.h,v 1.8 1999/08/03 18:07:15 redman Exp $ - */ - -#ifndef _TCLWININT -#define _TCLWININT - -#ifndef _TCLINT -#include "tclInt.h" -#endif -#ifndef _TCLPORT -#include "tclPort.h" -#endif - -/* - * The following specifies how much stack space TclpCheckStackSpace() - * ensures is available. TclpCheckStackSpace() is called by Tcl_EvalObj() - * to help avoid overflowing the stack in the case of infinite recursion. - */ - -#define TCL_WIN_STACK_THRESHOLD 0x2000 - -#ifdef BUILD_tcl -# undef TCL_STORAGE_CLASS -# define TCL_STORAGE_CLASS DLLEXPORT -#endif - -/* - * Some versions of Borland C have a define for the OSVERSIONINFO for - * Win32s and for NT, but not for Windows 95. - */ - -#ifndef VER_PLATFORM_WIN32_WINDOWS -#define VER_PLATFORM_WIN32_WINDOWS 1 -#endif - -/* - * The following structure keeps track of whether we are using the - * multi-byte or the wide-character interfaces to the operating system. - * System calls should be made through the following function table. - */ - -typedef union { - WIN32_FIND_DATAA a; - WIN32_FIND_DATAW w; -} WIN32_FIND_DATAT; - -typedef struct TclWinProcs { - int useWide; - - BOOL (WINAPI *buildCommDCBProc)(CONST TCHAR *, LPDCB); - TCHAR *(WINAPI *charLowerProc)(TCHAR *); - BOOL (WINAPI *copyFileProc)(CONST TCHAR *, CONST TCHAR *, BOOL); - BOOL (WINAPI *createDirectoryProc)(CONST TCHAR *, LPSECURITY_ATTRIBUTES); - HANDLE (WINAPI *createFileProc)(CONST TCHAR *, DWORD, DWORD, - LPSECURITY_ATTRIBUTES, DWORD, DWORD, HANDLE); - BOOL (WINAPI *createProcessProc)(CONST TCHAR *, TCHAR *, - LPSECURITY_ATTRIBUTES, LPSECURITY_ATTRIBUTES, BOOL, DWORD, - LPVOID, CONST TCHAR *, LPSTARTUPINFOA, LPPROCESS_INFORMATION); - BOOL (WINAPI *deleteFileProc)(CONST TCHAR *); - HANDLE (WINAPI *findFirstFileProc)(CONST TCHAR *, WIN32_FIND_DATAT *); - BOOL (WINAPI *findNextFileProc)(HANDLE, WIN32_FIND_DATAT *); - BOOL (WINAPI *getComputerNameProc)(WCHAR *, LPDWORD); - DWORD (WINAPI *getCurrentDirectoryProc)(DWORD, WCHAR *); - DWORD (WINAPI *getFileAttributesProc)(CONST TCHAR *); - DWORD (WINAPI *getFullPathNameProc)(CONST TCHAR *, DWORD nBufferLength, - WCHAR *, TCHAR **); - DWORD (WINAPI *getModuleFileNameProc)(HMODULE, WCHAR *, int); - DWORD (WINAPI *getShortPathNameProc)(CONST TCHAR *, WCHAR *, DWORD); - UINT (WINAPI *getTempFileNameProc)(CONST TCHAR *, CONST TCHAR *, UINT, - WCHAR *); - DWORD (WINAPI *getTempPathProc)(DWORD, WCHAR *); - BOOL (WINAPI *getVolumeInformationProc)(CONST TCHAR *, WCHAR *, DWORD, - LPDWORD, LPDWORD, LPDWORD, WCHAR *, DWORD); - HINSTANCE (WINAPI *loadLibraryProc)(CONST TCHAR *); - TCHAR (WINAPI *lstrcpyProc)(WCHAR *, CONST TCHAR *); - BOOL (WINAPI *moveFileProc)(CONST TCHAR *, CONST TCHAR *); - BOOL (WINAPI *removeDirectoryProc)(CONST TCHAR *); - DWORD (WINAPI *searchPathProc)(CONST TCHAR *, CONST TCHAR *, - CONST TCHAR *, DWORD, WCHAR *, TCHAR **); - BOOL (WINAPI *setCurrentDirectoryProc)(CONST TCHAR *); - BOOL (WINAPI *setFileAttributesProc)(CONST TCHAR *, DWORD); -} TclWinProcs; - -EXTERN TclWinProcs *tclWinProcs; -EXTERN Tcl_Encoding tclWinTCharEncoding; - -/* - * Declarations of functions that are not accessible by way of the - * stubs table. - */ - -EXTERN void TclWinInit(HINSTANCE hInst); - -# undef TCL_STORAGE_CLASS -# define TCL_STORAGE_CLASS DLLIMPORT - -#include "tclIntPlatDecls.h" - -#endif /* _TCLWININT */ diff --git a/win/tclWinLoad.c b/win/tclWinLoad.c deleted file mode 100644 index 360b629..0000000 --- a/win/tclWinLoad.c +++ /dev/null @@ -1,191 +0,0 @@ -/* - * tclWinLoad.c -- - * - * This procedure provides a version of the TclLoadFile that - * works with the Windows "LoadLibrary" and "GetProcAddress" - * API for dynamic loading. - * - * Copyright (c) 1995-1997 Sun Microsystems, Inc. - * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclWinLoad.c,v 1.5 2000/02/10 09:53:57 hobbs Exp $ - */ - -#include "tclWinInt.h" - - -/* - *---------------------------------------------------------------------- - * - * TclpLoadFile -- - * - * Dynamically loads a binary code file into memory and returns - * the addresses of two procedures within that file, if they - * are defined. - * - * Results: - * A standard Tcl completion code. If an error occurs, an error - * message is left in the interp's result. - * - * Side effects: - * New code suddenly appears in memory. - * - *---------------------------------------------------------------------- - */ - -int -TclpLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr, clientDataPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - char *fileName; /* Name of the file containing the desired - * code. */ - char *sym1, *sym2; /* Names of two procedures to look up in - * the file's symbol table. */ - Tcl_PackageInitProc **proc1Ptr, **proc2Ptr; - /* Where to return the addresses corresponding - * to sym1 and sym2. */ - ClientData *clientDataPtr; /* Filled with token for dynamically loaded - * file which will be passed back to - * TclpUnloadFile() to unload the file. */ -{ - HINSTANCE handle; - TCHAR *nativeName; - Tcl_DString ds; - - nativeName = Tcl_WinUtfToTChar(fileName, -1, &ds); - handle = (*tclWinProcs->loadLibraryProc)(nativeName); - Tcl_DStringFree(&ds); - - *clientDataPtr = (ClientData) handle; - - if (handle == NULL) { - DWORD lastError = GetLastError(); -#if 0 - /* - * It would be ideal if the FormatMessage stuff worked better, - * but unfortunately it doesn't seem to want to... - */ - LPTSTR lpMsgBuf; - char *buf; - int size; - size = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM | - FORMAT_MESSAGE_ALLOCATE_BUFFER, NULL, lastError, 0, - (LPTSTR) &lpMsgBuf, 0, NULL); - buf = (char *) ckalloc((unsigned) TCL_INTEGER_SPACE + size + 1); - sprintf(buf, "%d %s", lastError, (char *)lpMsgBuf); -#endif - Tcl_AppendResult(interp, "couldn't load library \"", - fileName, "\": ", (char *) NULL); - /* - * Check for possible DLL errors. This doesn't work quite right, - * because Windows seems to only return ERROR_MOD_NOT_FOUND for - * just about any problem, but it's better than nothing. It'd be - * even better if there was a way to get what DLLs - */ - switch (lastError) { - case ERROR_MOD_NOT_FOUND: - case ERROR_DLL_NOT_FOUND: - Tcl_AppendResult(interp, "this library or a dependent library", - " could not be found in library path", (char *) - NULL); - break; - case ERROR_INVALID_DLL: - Tcl_AppendResult(interp, "this library or a dependent library", - " is damaged", (char *) NULL); - break; - case ERROR_DLL_INIT_FAILED: - Tcl_AppendResult(interp, "the library initialization", - " routine failed", (char *) NULL); - break; - default: - TclWinConvertError(lastError); - Tcl_AppendResult(interp, Tcl_PosixError(interp), - (char *) NULL); - } - return TCL_ERROR; - } - - /* - * For each symbol, check for both Symbol and _Symbol, since Borland - * generates C symbols with a leading '_' by default. - */ - - *proc1Ptr = (Tcl_PackageInitProc *) GetProcAddress(handle, sym1); - if (*proc1Ptr == NULL) { - Tcl_DStringAppend(&ds, "_", 1); - sym1 = Tcl_DStringAppend(&ds, sym1, -1); - *proc1Ptr = (Tcl_PackageInitProc *) GetProcAddress(handle, sym1); - Tcl_DStringFree(&ds); - } - - *proc2Ptr = (Tcl_PackageInitProc *) GetProcAddress(handle, sym2); - if (*proc2Ptr == NULL) { - Tcl_DStringAppend(&ds, "_", 1); - sym2 = Tcl_DStringAppend(&ds, sym2, -1); - *proc2Ptr = (Tcl_PackageInitProc *) GetProcAddress(handle, sym2); - Tcl_DStringFree(&ds); - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclpUnloadFile -- - * - * Unloads a dynamically loaded binary code file from memory. - * Code pointers in the formerly loaded file are no longer valid - * after calling this function. - * - * Results: - * None. - * - * Side effects: - * Code removed from memory. - * - *---------------------------------------------------------------------- - */ - -void -TclpUnloadFile(clientData) - ClientData clientData; /* ClientData returned by a previous call - * to TclpLoadFile(). The clientData is - * a token that represents the loaded - * file. */ -{ - HINSTANCE handle; - - handle = (HINSTANCE) clientData; - FreeLibrary(handle); -} - -/* - *---------------------------------------------------------------------- - * - * TclGuessPackageName -- - * - * If the "load" command is invoked without providing a package - * name, this procedure is invoked to try to figure it out. - * - * Results: - * Always returns 0 to indicate that we couldn't figure out a - * package name; generic code will then try to guess the package - * from the file name. A return value of 1 would have meant that - * we figured out the package name and put it in bufPtr. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -TclGuessPackageName(fileName, bufPtr) - char *fileName; /* Name of file containing package (already - * translated to local form if needed). */ - Tcl_DString *bufPtr; /* Initialized empty dstring. Append - * package name to this if possible. */ -{ - return 0; -} diff --git a/win/tclWinMtherr.c b/win/tclWinMtherr.c deleted file mode 100644 index 7be9b97..0000000 --- a/win/tclWinMtherr.c +++ /dev/null @@ -1,52 +0,0 @@ -/* - * tclWinMtherr.c -- - * - * This function provides a default implementation of the - * _matherr function for Borland C++. - * - * Copyright (c) 1995 Sun Microsystems, Inc. - * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclWinMtherr.c,v 1.3 1999/04/16 00:48:09 stanton Exp $ - */ - -#include "tclWinInt.h" -#include <math.h> - - -/* - *---------------------------------------------------------------------- - * - * _matherr -- - * - * This procedure is invoked by Borland C++ when certain - * errors occur in mathematical functions. This procedure - * replaces the default implementation which generates pop-up - * warnings. - * - * Results: - * Returns 1 to indicate that we've handled the error - * locally. - * - * Side effects: - * Sets errno based on what's in xPtr. - * - *---------------------------------------------------------------------- - */ - -int -_matherr(xPtr) - struct exception *xPtr; /* Describes error that occurred. */ -{ - if (!TclMathInProgress()) { - return 0; - } - if ((xPtr->type == DOMAIN) || (xPtr->type == SING)) { - errno = EDOM; - } else { - errno = ERANGE; - } - return 1; -} diff --git a/win/tclWinNotify.c b/win/tclWinNotify.c deleted file mode 100644 index 932f86c..0000000 --- a/win/tclWinNotify.c +++ /dev/null @@ -1,514 +0,0 @@ -/* - * tclWinNotify.c -- - * - * This file contains Windows-specific procedures for the notifier, - * which is the lowest-level part of the Tcl event loop. This file - * works together with ../generic/tclNotify.c. - * - * Copyright (c) 1995-1997 Sun Microsystems, Inc. - * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclWinNotify.c,v 1.5 1999/07/02 22:08:28 redman Exp $ - */ - -#include "tclWinInt.h" -#include <winsock.h> - -/* - * The follwing static indicates whether this module has been initialized. - */ - -static int initialized = 0; - -#define INTERVAL_TIMER 1 /* Handle of interval timer. */ - -#define WM_WAKEUP WM_USER /* Message that is send by - * Tcl_AlertNotifier. */ -/* - * The following static structure contains the state information for the - * Windows implementation of the Tcl notifier. One of these structures - * is created for each thread that is using the notifier. - */ - -typedef struct ThreadSpecificData { - CRITICAL_SECTION crit; /* Monitor for this notifier. */ - DWORD thread; /* Identifier for thread associated with this - * notifier. */ - HANDLE event; /* Event object used to wake up the notifier - * thread. */ - int pending; /* Alert message pending, this field is - * locked by the notifierMutex. */ - HWND hwnd; /* Messaging window. */ - int timeout; /* Current timeout value. */ - int timerActive; /* 1 if interval timer is running. */ -} ThreadSpecificData; - -static Tcl_ThreadDataKey dataKey; - -extern TclStubs tclStubs; -/* - * The following static indicates the number of threads that have - * initialized notifiers. It controls the lifetime of the TclNotifier - * window class. - * - * You must hold the notifierMutex lock before accessing this variable. - */ - -static int notifierCount = 0; -TCL_DECLARE_MUTEX(notifierMutex) - -/* - * Static routines defined in this file. - */ - -static LRESULT CALLBACK NotifierProc(HWND hwnd, UINT message, - WPARAM wParam, LPARAM lParam); - - -/* - *---------------------------------------------------------------------- - * - * Tcl_InitNotifier -- - * - * Initializes the platform specific notifier state. - * - * Results: - * Returns a handle to the notifier state for this thread.. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -ClientData -Tcl_InitNotifier() -{ - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - WNDCLASS class; - - /* - * Register Notifier window class if this is the first thread to - * use this module. - */ - - Tcl_MutexLock(¬ifierMutex); - if (notifierCount == 0) { - class.style = 0; - class.cbClsExtra = 0; - class.cbWndExtra = 0; - class.hInstance = TclWinGetTclInstance(); - class.hbrBackground = NULL; - class.lpszMenuName = NULL; - class.lpszClassName = "TclNotifier"; - class.lpfnWndProc = NotifierProc; - class.hIcon = NULL; - class.hCursor = NULL; - - if (!RegisterClassA(&class)) { - panic("Unable to register TclNotifier window class"); - } - } - notifierCount++; - Tcl_MutexUnlock(¬ifierMutex); - - tsdPtr->pending = 0; - tsdPtr->timerActive = 0; - - InitializeCriticalSection(&tsdPtr->crit); - - tsdPtr->hwnd = NULL; - tsdPtr->thread = GetCurrentThreadId(); - tsdPtr->event = CreateEvent(NULL, TRUE /* manual */, - FALSE /* !signaled */, NULL); - - return (ClientData) tsdPtr; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_FinalizeNotifier -- - * - * This function is called to cleanup the notifier state before - * a thread is terminated. - * - * Results: - * None. - * - * Side effects: - * May dispose of the notifier window and class. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_FinalizeNotifier(clientData) - ClientData clientData; /* Pointer to notifier data. */ -{ - ThreadSpecificData *tsdPtr = (ThreadSpecificData *) clientData; - - DeleteCriticalSection(&tsdPtr->crit); - CloseHandle(tsdPtr->event); - - /* - * Clean up the timer and messaging window for this thread. - */ - - if (tsdPtr->hwnd) { - KillTimer(tsdPtr->hwnd, INTERVAL_TIMER); - DestroyWindow(tsdPtr->hwnd); - } - - /* - * If this is the last thread to use the notifier, unregister - * the notifier window class. - */ - - Tcl_MutexLock(¬ifierMutex); - notifierCount--; - if (notifierCount == 0) { - UnregisterClassA("TclNotifier", TclWinGetTclInstance()); - } - Tcl_MutexUnlock(¬ifierMutex); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_AlertNotifier -- - * - * Wake up the specified notifier from any thread. This routine - * is called by the platform independent notifier code whenever - * the Tcl_ThreadAlert routine is called. This routine is - * guaranteed not to be called on a given notifier after - * Tcl_FinalizeNotifier is called for that notifier. This routine - * is typically called from a thread other than the notifier's - * thread. - * - * Results: - * None. - * - * Side effects: - * Sends a message to the messaging window for the notifier - * if there isn't already one pending. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_AlertNotifier(clientData) - ClientData clientData; /* Pointer to thread data. */ -{ - ThreadSpecificData *tsdPtr = (ThreadSpecificData *) clientData; - - /* - * Note that we do not need to lock around access to the hwnd - * because the race condition has no effect since any race condition - * implies that the notifier thread is already awake. - */ - - if (tsdPtr->hwnd) { - /* - * We do need to lock around access to the pending flag. - */ - - EnterCriticalSection(&tsdPtr->crit); - if (!tsdPtr->pending) { - PostMessage(tsdPtr->hwnd, WM_WAKEUP, 0, 0); - } - tsdPtr->pending = 1; - LeaveCriticalSection(&tsdPtr->crit); - } else { - SetEvent(tsdPtr->event); - } -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_SetTimer -- - * - * This procedure sets the current notifier timer value. The - * notifier will ensure that Tcl_ServiceAll() is called after - * the specified interval, even if no events have occurred. - * - * Results: - * None. - * - * Side effects: - * Replaces any previous timer. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_SetTimer( - Tcl_Time *timePtr) /* Maximum block time, or NULL. */ -{ - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - UINT timeout; - - /* - * Allow the notifier to be hooked. This may not make sense - * on Windows, but mirrors the UNIX hook. - */ - - if (tclStubs.tcl_SetTimer != Tcl_SetTimer) { - tclStubs.tcl_SetTimer(timePtr); - return; - } - - /* - * We only need to set up an interval timer if we're being called - * from an external event loop. If we don't have a window handle - * then we just return immediately and let Tcl_WaitForEvent handle - * timeouts. - */ - - if (!tsdPtr->hwnd) { - return; - } - - if (!timePtr) { - timeout = 0; - } else { - /* - * Make sure we pass a non-zero value into the timeout argument. - * Windows seems to get confused by zero length timers. - */ - - timeout = timePtr->sec * 1000 + timePtr->usec / 1000; - if (timeout == 0) { - timeout = 1; - } - } - tsdPtr->timeout = timeout; - if (timeout != 0) { - tsdPtr->timerActive = 1; - SetTimer(tsdPtr->hwnd, INTERVAL_TIMER, - (unsigned long) tsdPtr->timeout, NULL); - } else { - tsdPtr->timerActive = 0; - KillTimer(tsdPtr->hwnd, INTERVAL_TIMER); - } -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_ServiceModeHook -- - * - * This function is invoked whenever the service mode changes. - * - * Results: - * None. - * - * Side effects: - * If this is the first time the notifier is set into - * TCL_SERVICE_ALL, then the communication window is created. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_ServiceModeHook(mode) - int mode; /* Either TCL_SERVICE_ALL, or - * TCL_SERVICE_NONE. */ -{ - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - - /* - * If this is the first time that the notifier has been used from a - * modal loop, then create a communication window. Note that after - * this point, the application needs to service events in a timely - * fashion or Windows will hang waiting for the window to respond - * to synchronous system messages. At some point, we may want to - * consider destroying the window if we leave the modal loop, but - * for now we'll leave it around. - */ - - if (mode == TCL_SERVICE_ALL && !tsdPtr->hwnd) { - tsdPtr->hwnd = CreateWindowA("TclNotifier", "TclNotifier", WS_TILED, - 0, 0, 0, 0, NULL, NULL, TclWinGetTclInstance(), NULL); - /* - * Send an initial message to the window to ensure that we wake up the - * notifier once we get into the modal loop. This will force the - * notifier to recompute the timeout value and schedule a timer - * if one is needed. - */ - - Tcl_AlertNotifier((ClientData)tsdPtr); - } -} - -/* - *---------------------------------------------------------------------- - * - * NotifierProc -- - * - * This procedure is invoked by Windows to process events on - * the notifier window. Messages will be sent to this window - * in response to external timer events or calls to - * TclpAlertTsdPtr-> - * - * Results: - * A standard windows result. - * - * Side effects: - * Services any pending events. - * - *---------------------------------------------------------------------- - */ - -static LRESULT CALLBACK -NotifierProc( - HWND hwnd, - UINT message, - WPARAM wParam, - LPARAM lParam) -{ - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - - if (message == WM_WAKEUP) { - EnterCriticalSection(&tsdPtr->crit); - tsdPtr->pending = 0; - LeaveCriticalSection(&tsdPtr->crit); - } else if (message != WM_TIMER) { - return DefWindowProc(hwnd, message, wParam, lParam); - } - - /* - * Process all of the runnable events. - */ - - Tcl_ServiceAll(); - return 0; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_WaitForEvent -- - * - * This function is called by Tcl_DoOneEvent to wait for new - * events on the message queue. If the block time is 0, then - * Tcl_WaitForEvent just polls the event queue without blocking. - * - * Results: - * Returns -1 if a WM_QUIT message is detected, returns 1 if - * a message was dispatched, otherwise returns 0. - * - * Side effects: - * Dispatches a message to a window procedure, which could do - * anything. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_WaitForEvent( - Tcl_Time *timePtr) /* Maximum block time, or NULL. */ -{ - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - MSG msg; - DWORD timeout, result; - int status; - - /* - * Allow the notifier to be hooked. This may not make - * sense on windows, but mirrors the UNIX hook. - */ - - if (tclStubs.tcl_WaitForEvent != Tcl_WaitForEvent) { - return tclStubs.tcl_WaitForEvent(timePtr); - } - - /* - * Compute the timeout in milliseconds. - */ - - if (timePtr) { - timeout = timePtr->sec * 1000 + timePtr->usec / 1000; - } else { - timeout = INFINITE; - } - - /* - * Check to see if there are any messages in the queue before waiting - * because MsgWaitForMultipleObjects will not wake up if there are events - * currently sitting in the queue. - */ - - if (!PeekMessage(&msg, NULL, 0, 0, PM_NOREMOVE)) { - /* - * Wait for something to happen (a signal from another thread, a - * message, or timeout). - */ - - result = MsgWaitForMultipleObjects(1, &tsdPtr->event, FALSE, timeout, - QS_ALLINPUT); - } - - /* - * Check to see if there are any messages to process. - */ - - if (PeekMessage(&msg, NULL, 0, 0, PM_NOREMOVE)) { - /* - * Retrieve and dispatch the first message. - */ - - result = GetMessage(&msg, NULL, 0, 0); - if (result == 0) { - /* - * We received a request to exit this thread (WM_QUIT), so - * propagate the quit message and start unwinding. - */ - - PostQuitMessage(msg.wParam); - status = -1; - } else if (result == -1) { - /* - * We got an error from the system. I have no idea why this would - * happen, so we'll just unwind. - */ - - status = -1; - } else { - TranslateMessage(&msg); - DispatchMessage(&msg); - status = 1; - } - } else { - status = 0; - } - - ResetEvent(tsdPtr->event); - return status; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_Sleep -- - * - * Delay execution for the specified number of milliseconds. - * - * Results: - * None. - * - * Side effects: - * Time passes. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_Sleep(ms) - int ms; /* Number of milliseconds to sleep. */ -{ - Sleep(ms); -} diff --git a/win/tclWinPipe.c b/win/tclWinPipe.c deleted file mode 100644 index 0f3793a..0000000 --- a/win/tclWinPipe.c +++ /dev/null @@ -1,2825 +0,0 @@ -/* - * tclWinPipe.c -- - * - * This file implements the Windows-specific exec pipeline functions, - * the "pipe" channel driver, and the "pid" Tcl command. - * - * Copyright (c) 1996-1997 by Sun Microsystems, Inc. - * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclWinPipe.c,v 1.11.2.1 2000/07/27 01:39:25 hobbs Exp $ - */ - -#include "tclWinInt.h" - -#include <dos.h> -#include <fcntl.h> -#include <io.h> -#include <sys/stat.h> - -/* - * The following variable is used to tell whether this module has been - * initialized. - */ - -static int initialized = 0; - -/* - * The pipeMutex locks around access to the initialized and procList variables, - * and it is used to protect background threads from being terminated while - * they are using APIs that hold locks. - */ - -TCL_DECLARE_MUTEX(pipeMutex) - -/* - * The following defines identify the various types of applications that - * run under windows. There is special case code for the various types. - */ - -#define APPL_NONE 0 -#define APPL_DOS 1 -#define APPL_WIN3X 2 -#define APPL_WIN32 3 - -/* - * The following constants and structures are used to encapsulate the state - * of various types of files used in a pipeline. - * This used to have a 1 && 2 that supported Win32s. - */ - -#define WIN_FILE 3 /* Basic Win32 file. */ - -/* - * This structure encapsulates the common state associated with all file - * types used in a pipeline. - */ - -typedef struct WinFile { - int type; /* One of the file types defined above. */ - HANDLE handle; /* Open file handle. */ -} WinFile; - -/* - * This list is used to map from pids to process handles. - */ - -typedef struct ProcInfo { - HANDLE hProcess; - DWORD dwProcessId; - struct ProcInfo *nextPtr; -} ProcInfo; - -static ProcInfo *procList; - -/* - * Bit masks used in the flags field of the PipeInfo structure below. - */ - -#define PIPE_PENDING (1<<0) /* Message is pending in the queue. */ -#define PIPE_ASYNC (1<<1) /* Channel is non-blocking. */ - -/* - * Bit masks used in the sharedFlags field of the PipeInfo structure below. - */ - -#define PIPE_EOF (1<<2) /* Pipe has reached EOF. */ -#define PIPE_EXTRABYTE (1<<3) /* The reader thread has consumed one byte. */ - -/* - * This structure describes per-instance data for a pipe based channel. - */ - -typedef struct PipeInfo { - struct PipeInfo *nextPtr; /* Pointer to next registered pipe. */ - Tcl_Channel channel; /* Pointer to channel structure. */ - int validMask; /* OR'ed combination of TCL_READABLE, - * TCL_WRITABLE, or TCL_EXCEPTION: indicates - * which operations are valid on the file. */ - int watchMask; /* OR'ed combination of TCL_READABLE, - * TCL_WRITABLE, or TCL_EXCEPTION: indicates - * which events should be reported. */ - int flags; /* State flags, see above for a list. */ - TclFile readFile; /* Output from pipe. */ - TclFile writeFile; /* Input from pipe. */ - TclFile errorFile; /* Error output from pipe. */ - int numPids; /* Number of processes attached to pipe. */ - Tcl_Pid *pidPtr; /* Pids of attached processes. */ - Tcl_ThreadId threadId; /* Thread to which events should be reported. - * This value is used by the reader/writer - * threads. */ - HANDLE writeThread; /* Handle to writer thread. */ - HANDLE readThread; /* Handle to reader thread. */ - HANDLE writable; /* Manual-reset event to signal when the - * writer thread has finished waiting for - * the current buffer to be written. */ - HANDLE readable; /* Manual-reset event to signal when the - * reader thread has finished waiting for - * input. */ - HANDLE startWriter; /* Auto-reset event used by the main thread to - * signal when the writer thread should attempt - * to write to the pipe. */ - HANDLE startReader; /* Auto-reset event used by the main thread to - * signal when the reader thread should attempt - * to read from the pipe. */ - DWORD writeError; /* An error caused by the last background - * write. Set to 0 if no error has been - * detected. This word is shared with the - * writer thread so access must be - * synchronized with the writable object. - */ - char *writeBuf; /* Current background output buffer. - * Access is synchronized with the writable - * object. */ - int writeBufLen; /* Size of write buffer. Access is - * synchronized with the writable - * object. */ - int toWrite; /* Current amount to be written. Access is - * synchronized with the writable object. */ - int readFlags; /* Flags that are shared with the reader - * thread. Access is synchronized with the - * readable object. */ - char extraByte; /* Buffer for extra character consumed by - * reader thread. This byte is shared with - * the reader thread so access must be - * synchronized with the readable object. */ -} PipeInfo; - -typedef struct ThreadSpecificData { - /* - * The following pointer refers to the head of the list of pipes - * that are being watched for file events. - */ - - PipeInfo *firstPipePtr; -} ThreadSpecificData; - -static Tcl_ThreadDataKey dataKey; - -/* - * The following structure is what is added to the Tcl event queue when - * pipe events are generated. - */ - -typedef struct PipeEvent { - Tcl_Event header; /* Information that is standard for - * all events. */ - PipeInfo *infoPtr; /* Pointer to pipe info structure. Note - * that we still have to verify that the - * pipe exists before dereferencing this - * pointer. */ -} PipeEvent; - -/* - * Declarations for functions used only in this file. - */ - -static int ApplicationType(Tcl_Interp *interp, - const char *fileName, char *fullName); -static void BuildCommandLine(const char *executable, int argc, - char **argv, Tcl_DString *linePtr); -static BOOL HasConsole(void); -static int PipeBlockModeProc(ClientData instanceData, int mode); -static void PipeCheckProc(ClientData clientData, int flags); -static int PipeClose2Proc(ClientData instanceData, - Tcl_Interp *interp, int flags); -static int PipeEventProc(Tcl_Event *evPtr, int flags); -static void PipeExitHandler(ClientData clientData); -static int PipeGetHandleProc(ClientData instanceData, - int direction, ClientData *handlePtr); -static void PipeInit(void); -static int PipeInputProc(ClientData instanceData, char *buf, - int toRead, int *errorCode); -static int PipeOutputProc(ClientData instanceData, char *buf, - int toWrite, int *errorCode); -static DWORD WINAPI PipeReaderThread(LPVOID arg); -static void PipeSetupProc(ClientData clientData, int flags); -static void PipeWatchProc(ClientData instanceData, int mask); -static DWORD WINAPI PipeWriterThread(LPVOID arg); -static void ProcExitHandler(ClientData clientData); -static int TempFileName(WCHAR name[MAX_PATH]); -static int WaitForRead(PipeInfo *infoPtr, int blocking); - -/* - * This structure describes the channel type structure for command pipe - * based IO. - */ - -static Tcl_ChannelType pipeChannelType = { - "pipe", /* Type name. */ - TCL_CHANNEL_VERSION_2, /* v2 channel */ - TCL_CLOSE2PROC, /* Close proc. */ - PipeInputProc, /* Input proc. */ - PipeOutputProc, /* Output proc. */ - NULL, /* Seek proc. */ - NULL, /* Set option proc. */ - NULL, /* Get option proc. */ - PipeWatchProc, /* Set up notifier to watch the channel. */ - PipeGetHandleProc, /* Get an OS handle from channel. */ - PipeClose2Proc, /* close2proc */ - PipeBlockModeProc, /* Set blocking or non-blocking mode.*/ - NULL, /* flush proc. */ - NULL, /* handler proc. */ -}; - -/* - *---------------------------------------------------------------------- - * - * PipeInit -- - * - * This function initializes the static variables for this file. - * - * Results: - * None. - * - * Side effects: - * Creates a new event source. - * - *---------------------------------------------------------------------- - */ - -static void -PipeInit() -{ - ThreadSpecificData *tsdPtr; - - /* - * Check the initialized flag first, then check again in the mutex. - * This is a speed enhancement. - */ - - if (!initialized) { - Tcl_MutexLock(&pipeMutex); - if (!initialized) { - initialized = 1; - procList = NULL; - Tcl_CreateExitHandler(ProcExitHandler, NULL); - } - Tcl_MutexUnlock(&pipeMutex); - } - - tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey); - if (tsdPtr == NULL) { - tsdPtr = TCL_TSD_INIT(&dataKey); - tsdPtr->firstPipePtr = NULL; - Tcl_CreateEventSource(PipeSetupProc, PipeCheckProc, NULL); - Tcl_CreateThreadExitHandler(PipeExitHandler, NULL); - } -} - -/* - *---------------------------------------------------------------------- - * - * PipeExitHandler -- - * - * This function is called to cleanup the pipe module before - * Tcl is unloaded. - * - * Results: - * None. - * - * Side effects: - * Removes the pipe event source. - * - *---------------------------------------------------------------------- - */ - -static void -PipeExitHandler( - ClientData clientData) /* Old window proc */ -{ - Tcl_DeleteEventSource(PipeSetupProc, PipeCheckProc, NULL); -} - -/* - *---------------------------------------------------------------------- - * - * ProcExitHandler -- - * - * This function is called to cleanup the process list before - * Tcl is unloaded. - * - * Results: - * None. - * - * Side effects: - * Resets the process list. - * - *---------------------------------------------------------------------- - */ - -static void -ProcExitHandler( - ClientData clientData) /* Old window proc */ -{ - Tcl_MutexLock(&pipeMutex); - initialized = 0; - Tcl_MutexUnlock(&pipeMutex); -} - -/* - *---------------------------------------------------------------------- - * - * PipeSetupProc -- - * - * This procedure is invoked before Tcl_DoOneEvent blocks waiting - * for an event. - * - * Results: - * None. - * - * Side effects: - * Adjusts the block time if needed. - * - *---------------------------------------------------------------------- - */ - -void -PipeSetupProc( - ClientData data, /* Not used. */ - int flags) /* Event flags as passed to Tcl_DoOneEvent. */ -{ - PipeInfo *infoPtr; - Tcl_Time blockTime = { 0, 0 }; - int block = 1; - WinFile *filePtr; - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - - if (!(flags & TCL_FILE_EVENTS)) { - return; - } - - /* - * Look to see if any events are already pending. If they are, poll. - */ - - for (infoPtr = tsdPtr->firstPipePtr; infoPtr != NULL; - infoPtr = infoPtr->nextPtr) { - if (infoPtr->watchMask & TCL_WRITABLE) { - filePtr = (WinFile*) infoPtr->writeFile; - if (WaitForSingleObject(infoPtr->writable, 0) != WAIT_TIMEOUT) { - block = 0; - } - } - if (infoPtr->watchMask & TCL_READABLE) { - filePtr = (WinFile*) infoPtr->readFile; - if (WaitForRead(infoPtr, 0) >= 0) { - block = 0; - } - } - } - if (!block) { - Tcl_SetMaxBlockTime(&blockTime); - } -} - -/* - *---------------------------------------------------------------------- - * - * PipeCheckProc -- - * - * This procedure is called by Tcl_DoOneEvent to check the pipe - * event source for events. - * - * Results: - * None. - * - * Side effects: - * May queue an event. - * - *---------------------------------------------------------------------- - */ - -static void -PipeCheckProc( - ClientData data, /* Not used. */ - int flags) /* Event flags as passed to Tcl_DoOneEvent. */ -{ - PipeInfo *infoPtr; - PipeEvent *evPtr; - WinFile *filePtr; - int needEvent; - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - - if (!(flags & TCL_FILE_EVENTS)) { - return; - } - - /* - * Queue events for any ready pipes that don't already have events - * queued. - */ - - for (infoPtr = tsdPtr->firstPipePtr; infoPtr != NULL; - infoPtr = infoPtr->nextPtr) { - if (infoPtr->flags & PIPE_PENDING) { - continue; - } - - /* - * Queue an event if the pipe is signaled for reading or writing. - */ - - needEvent = 0; - filePtr = (WinFile*) infoPtr->writeFile; - if ((infoPtr->watchMask & TCL_WRITABLE) && - (WaitForSingleObject(infoPtr->writable, 0) != WAIT_TIMEOUT)) { - needEvent = 1; - } - - filePtr = (WinFile*) infoPtr->readFile; - if ((infoPtr->watchMask & TCL_READABLE) && - (WaitForRead(infoPtr, 0) >= 0)) { - needEvent = 1; - } - - if (needEvent) { - infoPtr->flags |= PIPE_PENDING; - evPtr = (PipeEvent *) ckalloc(sizeof(PipeEvent)); - evPtr->header.proc = PipeEventProc; - evPtr->infoPtr = infoPtr; - Tcl_QueueEvent((Tcl_Event *) evPtr, TCL_QUEUE_TAIL); - } - } -} - -/* - *---------------------------------------------------------------------- - * - * TclWinMakeFile -- - * - * This function constructs a new TclFile from a given data and - * type value. - * - * Results: - * Returns a newly allocated WinFile as a TclFile. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -TclFile -TclWinMakeFile( - HANDLE handle) /* Type-specific data. */ -{ - WinFile *filePtr; - - filePtr = (WinFile *) ckalloc(sizeof(WinFile)); - filePtr->type = WIN_FILE; - filePtr->handle = handle; - - return (TclFile)filePtr; -} - -/* - *---------------------------------------------------------------------- - * - * TempFileName -- - * - * Gets a temporary file name and deals with the fact that the - * temporary file path provided by Windows may not actually exist - * if the TMP or TEMP environment variables refer to a - * non-existent directory. - * - * Results: - * 0 if error, non-zero otherwise. If non-zero is returned, the - * name buffer will be filled with a name that can be used to - * construct a temporary file. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -TempFileName(name) - WCHAR name[MAX_PATH]; /* Buffer in which name for temporary - * file gets stored. */ -{ - TCHAR *prefix; - - prefix = (tclWinProcs->useWide) ? (TCHAR *) L"TCL" : (TCHAR *) "TCL"; - if ((*tclWinProcs->getTempPathProc)(MAX_PATH, name) != 0) { - if ((*tclWinProcs->getTempFileNameProc)((TCHAR *) name, prefix, 0, - name) != 0) { - return 1; - } - } - if (tclWinProcs->useWide) { - ((WCHAR *) name)[0] = '.'; - ((WCHAR *) name)[1] = '\0'; - } else { - ((char *) name)[0] = '.'; - ((char *) name)[1] = '\0'; - } - return (*tclWinProcs->getTempFileNameProc)((TCHAR *) name, prefix, 0, - name); -} - -/* - *---------------------------------------------------------------------- - * - * TclpMakeFile -- - * - * Make a TclFile from a channel. - * - * Results: - * Returns a new TclFile or NULL on failure. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -TclFile -TclpMakeFile(channel, direction) - Tcl_Channel channel; /* Channel to get file from. */ - int direction; /* Either TCL_READABLE or TCL_WRITABLE. */ -{ - HANDLE handle; - - if (Tcl_GetChannelHandle(channel, direction, - (ClientData *) &handle) == TCL_OK) { - return TclWinMakeFile(handle); - } else { - return (TclFile) NULL; - } -} - -/* - *---------------------------------------------------------------------- - * - * TclpOpenFile -- - * - * This function opens files for use in a pipeline. - * - * Results: - * Returns a newly allocated TclFile structure containing the - * file handle. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -TclFile -TclpOpenFile(path, mode) - CONST char *path; /* The name of the file to open. */ - int mode; /* In what mode to open the file? */ -{ - HANDLE handle; - DWORD accessMode, createMode, shareMode, flags; - Tcl_DString ds; - TCHAR *nativePath; - - /* - * Map the access bits to the NT access mode. - */ - - switch (mode & (O_RDONLY | O_WRONLY | O_RDWR)) { - case O_RDONLY: - accessMode = GENERIC_READ; - break; - case O_WRONLY: - accessMode = GENERIC_WRITE; - break; - case O_RDWR: - accessMode = (GENERIC_READ | GENERIC_WRITE); - break; - default: - TclWinConvertError(ERROR_INVALID_FUNCTION); - return NULL; - } - - /* - * Map the creation flags to the NT create mode. - */ - - switch (mode & (O_CREAT | O_EXCL | O_TRUNC)) { - case (O_CREAT | O_EXCL): - case (O_CREAT | O_EXCL | O_TRUNC): - createMode = CREATE_NEW; - break; - case (O_CREAT | O_TRUNC): - createMode = CREATE_ALWAYS; - break; - case O_CREAT: - createMode = OPEN_ALWAYS; - break; - case O_TRUNC: - case (O_TRUNC | O_EXCL): - createMode = TRUNCATE_EXISTING; - break; - default: - createMode = OPEN_EXISTING; - break; - } - - nativePath = Tcl_WinUtfToTChar(path, -1, &ds); - - /* - * If the file is not being created, use the existing file attributes. - */ - - flags = 0; - if (!(mode & O_CREAT)) { - flags = (*tclWinProcs->getFileAttributesProc)(nativePath); - if (flags == 0xFFFFFFFF) { - flags = 0; - } - } - - /* - * Set up the file sharing mode. We want to allow simultaneous access. - */ - - shareMode = FILE_SHARE_READ | FILE_SHARE_WRITE; - - /* - * Now we get to create the file. - */ - - handle = (*tclWinProcs->createFileProc)(nativePath, accessMode, - shareMode, NULL, createMode, flags, NULL); - Tcl_DStringFree(&ds); - - if (handle == INVALID_HANDLE_VALUE) { - DWORD err; - - err = GetLastError(); - if ((err & 0xffffL) == ERROR_OPEN_FAILED) { - err = (mode & O_CREAT) ? ERROR_FILE_EXISTS : ERROR_FILE_NOT_FOUND; - } - TclWinConvertError(err); - return NULL; - } - - /* - * Seek to the end of file if we are writing. - */ - - if (mode & O_WRONLY) { - SetFilePointer(handle, 0, NULL, FILE_END); - } - - return TclWinMakeFile(handle); -} - -/* - *---------------------------------------------------------------------- - * - * TclpCreateTempFile -- - * - * This function opens a unique file with the property that it - * will be deleted when its file handle is closed. The temporary - * file is created in the system temporary directory. - * - * Results: - * Returns a valid TclFile, or NULL on failure. - * - * Side effects: - * Creates a new temporary file. - * - *---------------------------------------------------------------------- - */ - -TclFile -TclpCreateTempFile(contents) - CONST char *contents; /* String to write into temp file, or NULL. */ -{ - WCHAR name[MAX_PATH]; - CONST char *native; - Tcl_DString dstring; - HANDLE handle; - - if (TempFileName(name) == 0) { - return NULL; - } - - handle = (*tclWinProcs->createFileProc)((TCHAR *) name, - GENERIC_READ | GENERIC_WRITE, 0, NULL, CREATE_ALWAYS, - FILE_ATTRIBUTE_TEMPORARY|FILE_FLAG_DELETE_ON_CLOSE, NULL); - if (handle == INVALID_HANDLE_VALUE) { - goto error; - } - - /* - * Write the file out, doing line translations on the way. - */ - - if (contents != NULL) { - DWORD result, length; - CONST char *p; - - /* - * Convert the contents from UTF to native encoding - */ - native = Tcl_UtfToExternalDString(NULL, contents, -1, &dstring); - - for (p = native; *p != '\0'; p++) { - if (*p == '\n') { - length = p - native; - if (length > 0) { - if (!WriteFile(handle, native, length, &result, NULL)) { - goto error; - } - } - if (!WriteFile(handle, "\r\n", 2, &result, NULL)) { - goto error; - } - native = p+1; - } - } - length = p - native; - if (length > 0) { - if (!WriteFile(handle, native, length, &result, NULL)) { - goto error; - } - } - Tcl_DStringFree(&dstring); - if (SetFilePointer(handle, 0, NULL, FILE_BEGIN) == 0xFFFFFFFF) { - goto error; - } - } - - return TclWinMakeFile(handle); - - error: - /* Free the native representation of the contents if necessary */ - if (contents != NULL) { - Tcl_DStringFree(&dstring); - } - - TclWinConvertError(GetLastError()); - CloseHandle(handle); - (*tclWinProcs->deleteFileProc)((TCHAR *) name); - return NULL; -} - -/* - *---------------------------------------------------------------------- - * - * TclpCreatePipe -- - * - * Creates an anonymous pipe. - * - * Results: - * Returns 1 on success, 0 on failure. - * - * Side effects: - * Creates a pipe. - * - *---------------------------------------------------------------------- - */ - -int -TclpCreatePipe( - TclFile *readPipe, /* Location to store file handle for - * read side of pipe. */ - TclFile *writePipe) /* Location to store file handle for - * write side of pipe. */ -{ - HANDLE readHandle, writeHandle; - - if (CreatePipe(&readHandle, &writeHandle, NULL, 0) != 0) { - *readPipe = TclWinMakeFile(readHandle); - *writePipe = TclWinMakeFile(writeHandle); - return 1; - } - - TclWinConvertError(GetLastError()); - return 0; -} - -/* - *---------------------------------------------------------------------- - * - * TclpCloseFile -- - * - * Closes a pipeline file handle. These handles are created by - * TclpOpenFile, TclpCreatePipe, or TclpMakeFile. - * - * Results: - * 0 on success, -1 on failure. - * - * Side effects: - * The file is closed and deallocated. - * - *---------------------------------------------------------------------- - */ - -int -TclpCloseFile( - TclFile file) /* The file to close. */ -{ - WinFile *filePtr = (WinFile *) file; - - switch (filePtr->type) { - case WIN_FILE: - /* - * Don't close the Win32 handle if the handle is a standard channel - * during the exit process. Otherwise, one thread may kill the - * stdio of another. - */ - - if (!TclInExit() - || ((GetStdHandle(STD_INPUT_HANDLE) != filePtr->handle) - && (GetStdHandle(STD_OUTPUT_HANDLE) != filePtr->handle) - && (GetStdHandle(STD_ERROR_HANDLE) != filePtr->handle))) { - if (CloseHandle(filePtr->handle) == FALSE) { - TclWinConvertError(GetLastError()); - ckfree((char *) filePtr); - return -1; - } - } - break; - - default: - panic("TclpCloseFile: unexpected file type"); - } - - ckfree((char *) filePtr); - return 0; -} - -/* - *-------------------------------------------------------------------------- - * - * TclpGetPid -- - * - * Given a HANDLE to a child process, return the process id for that - * child process. - * - * Results: - * Returns the process id for the child process. If the pid was not - * known by Tcl, either because the pid was not created by Tcl or the - * child process has already been reaped, -1 is returned. - * - * Side effects: - * None. - * - *-------------------------------------------------------------------------- - */ - -unsigned long -TclpGetPid( - Tcl_Pid pid) /* The HANDLE of the child process. */ -{ - ProcInfo *infoPtr; - - Tcl_MutexLock(&pipeMutex); - for (infoPtr = procList; infoPtr != NULL; infoPtr = infoPtr->nextPtr) { - if (infoPtr->hProcess == (HANDLE) pid) { - Tcl_MutexUnlock(&pipeMutex); - return infoPtr->dwProcessId; - } - } - Tcl_MutexUnlock(&pipeMutex); - return (unsigned long) -1; -} - -/* - *---------------------------------------------------------------------- - * - * TclpCreateProcess -- - * - * Create a child process that has the specified files as its - * standard input, output, and error. The child process runs - * asynchronously under Windows NT and Windows 9x, and runs - * with the same environment variables as the creating process. - * - * The complete Windows search path is searched to find the specified - * executable. If an executable by the given name is not found, - * automatically tries appending ".com", ".exe", and ".bat" to the - * executable name. - * - * Results: - * The return value is TCL_ERROR and an error message is left in - * the interp's result if there was a problem creating the child - * process. Otherwise, the return value is TCL_OK and *pidPtr is - * filled with the process id of the child process. - * - * Side effects: - * A process is created. - * - *---------------------------------------------------------------------- - */ - -int -TclpCreateProcess( - Tcl_Interp *interp, /* Interpreter in which to leave errors that - * occurred when creating the child process. - * Error messages from the child process - * itself are sent to errorFile. */ - int argc, /* Number of arguments in following array. */ - char **argv, /* Array of argument strings. argv[0] - * contains the name of the executable - * converted to native format (using the - * Tcl_TranslateFileName call). Additional - * arguments have not been converted. */ - TclFile inputFile, /* If non-NULL, gives the file to use as - * input for the child process. If inputFile - * file is not readable or is NULL, the child - * will receive no standard input. */ - TclFile outputFile, /* If non-NULL, gives the file that - * receives output from the child process. If - * outputFile file is not writeable or is - * NULL, output from the child will be - * discarded. */ - TclFile errorFile, /* If non-NULL, gives the file that - * receives errors from the child process. If - * errorFile file is not writeable or is NULL, - * errors from the child will be discarded. - * errorFile may be the same as outputFile. */ - Tcl_Pid *pidPtr) /* If this procedure is successful, pidPtr - * is filled with the process id of the child - * process. */ -{ - int result, applType, createFlags; - Tcl_DString cmdLine; /* Complete command line (TCHAR). */ - STARTUPINFOA startInfo; - PROCESS_INFORMATION procInfo; - SECURITY_ATTRIBUTES secAtts; - HANDLE hProcess, h, inputHandle, outputHandle, errorHandle; - char execPath[MAX_PATH * TCL_UTF_MAX]; - WinFile *filePtr; - - PipeInit(); - - applType = ApplicationType(interp, argv[0], execPath); - if (applType == APPL_NONE) { - return TCL_ERROR; - } - - result = TCL_ERROR; - Tcl_DStringInit(&cmdLine); - hProcess = GetCurrentProcess(); - - /* - * STARTF_USESTDHANDLES must be used to pass handles to child process. - * Using SetStdHandle() and/or dup2() only works when a console mode - * parent process is spawning an attached console mode child process. - */ - - ZeroMemory(&startInfo, sizeof(startInfo)); - startInfo.cb = sizeof(startInfo); - startInfo.dwFlags = STARTF_USESTDHANDLES; - startInfo.hStdInput = INVALID_HANDLE_VALUE; - startInfo.hStdOutput= INVALID_HANDLE_VALUE; - startInfo.hStdError = INVALID_HANDLE_VALUE; - - secAtts.nLength = sizeof(SECURITY_ATTRIBUTES); - secAtts.lpSecurityDescriptor = NULL; - secAtts.bInheritHandle = TRUE; - - /* - * We have to check the type of each file, since we cannot duplicate - * some file types. - */ - - inputHandle = INVALID_HANDLE_VALUE; - if (inputFile != NULL) { - filePtr = (WinFile *)inputFile; - if (filePtr->type == WIN_FILE) { - inputHandle = filePtr->handle; - } - } - outputHandle = INVALID_HANDLE_VALUE; - if (outputFile != NULL) { - filePtr = (WinFile *)outputFile; - if (filePtr->type == WIN_FILE) { - outputHandle = filePtr->handle; - } - } - errorHandle = INVALID_HANDLE_VALUE; - if (errorFile != NULL) { - filePtr = (WinFile *)errorFile; - if (filePtr->type == WIN_FILE) { - errorHandle = filePtr->handle; - } - } - - /* - * Duplicate all the handles which will be passed off as stdin, stdout - * and stderr of the child process. The duplicate handles are set to - * be inheritable, so the child process can use them. - */ - - if (inputHandle == INVALID_HANDLE_VALUE) { - /* - * If handle was not set, stdin should return immediate EOF. - * Under Windows95, some applications (both 16 and 32 bit!) - * cannot read from the NUL device; they read from console - * instead. When running tk, this is fatal because the child - * process would hang forever waiting for EOF from the unmapped - * console window used by the helper application. - * - * Fortunately, the helper application detects a closed pipe - * as an immediate EOF and can pass that information to the - * child process. - */ - - if (CreatePipe(&startInfo.hStdInput, &h, &secAtts, 0) != FALSE) { - CloseHandle(h); - } - } else { - DuplicateHandle(hProcess, inputHandle, hProcess, &startInfo.hStdInput, - 0, TRUE, DUPLICATE_SAME_ACCESS); - } - if (startInfo.hStdInput == INVALID_HANDLE_VALUE) { - TclWinConvertError(GetLastError()); - Tcl_AppendResult(interp, "couldn't duplicate input handle: ", - Tcl_PosixError(interp), (char *) NULL); - goto end; - } - - if (outputHandle == INVALID_HANDLE_VALUE) { - /* - * If handle was not set, output should be sent to an infinitely - * deep sink. Under Windows 95, some 16 bit applications cannot - * have stdout redirected to NUL; they send their output to - * the console instead. Some applications, like "more" or "dir /p", - * when outputting multiple pages to the console, also then try and - * read from the console to go the next page. When running tk, this - * is fatal because the child process would hang forever waiting - * for input from the unmapped console window used by the helper - * application. - * - * Fortunately, the helper application will detect a closed pipe - * as a sink. - */ - - if ((TclWinGetPlatformId() == VER_PLATFORM_WIN32_WINDOWS) - && (applType == APPL_DOS)) { - if (CreatePipe(&h, &startInfo.hStdOutput, &secAtts, 0) != FALSE) { - CloseHandle(h); - } - } else { - startInfo.hStdOutput = CreateFileA("NUL:", GENERIC_WRITE, 0, - &secAtts, OPEN_ALWAYS, FILE_ATTRIBUTE_NORMAL, NULL); - } - } else { - DuplicateHandle(hProcess, outputHandle, hProcess, &startInfo.hStdOutput, - 0, TRUE, DUPLICATE_SAME_ACCESS); - } - if (startInfo.hStdOutput == INVALID_HANDLE_VALUE) { - TclWinConvertError(GetLastError()); - Tcl_AppendResult(interp, "couldn't duplicate output handle: ", - Tcl_PosixError(interp), (char *) NULL); - goto end; - } - - if (errorHandle == INVALID_HANDLE_VALUE) { - /* - * If handle was not set, errors should be sent to an infinitely - * deep sink. - */ - - startInfo.hStdError = CreateFileA("NUL:", GENERIC_WRITE, 0, - &secAtts, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, NULL); - } else { - DuplicateHandle(hProcess, errorHandle, hProcess, &startInfo.hStdError, - 0, TRUE, DUPLICATE_SAME_ACCESS); - } - if (startInfo.hStdError == INVALID_HANDLE_VALUE) { - TclWinConvertError(GetLastError()); - Tcl_AppendResult(interp, "couldn't duplicate error handle: ", - Tcl_PosixError(interp), (char *) NULL); - goto end; - } - /* - * If we do not have a console window, then we must run DOS and - * WIN32 console mode applications as detached processes. This tells - * the loader that the child application should not inherit the - * console, and that it should not create a new console window for - * the child application. The child application should get its stdio - * from the redirection handles provided by this application, and run - * in the background. - * - * If we are starting a GUI process, they don't automatically get a - * console, so it doesn't matter if they are started as foreground or - * detached processes. The GUI window will still pop up to the - * foreground. - */ - - if (TclWinGetPlatformId() == VER_PLATFORM_WIN32_NT) { - if (HasConsole()) { - createFlags = 0; - } else if (applType == APPL_DOS) { - /* - * Under NT, 16-bit DOS applications will not run unless they - * can be attached to a console. If we are running without a - * console, run the 16-bit program as an normal process inside - * of a hidden console application, and then run that hidden - * console as a detached process. - */ - - startInfo.wShowWindow = SW_HIDE; - startInfo.dwFlags |= STARTF_USESHOWWINDOW; - createFlags = CREATE_NEW_CONSOLE; - Tcl_DStringAppend(&cmdLine, "cmd.exe /c ", -1); - } else { - createFlags = DETACHED_PROCESS; - } - } else { - if (HasConsole()) { - createFlags = 0; - } else { - createFlags = DETACHED_PROCESS; - } - - if (applType == APPL_DOS) { - /* - * Under Windows 95, 16-bit DOS applications do not work well - * with pipes: - * - * 1. EOF on a pipe between a detached 16-bit DOS application - * and another application is not seen at the other - * end of the pipe, so the listening process blocks forever on - * reads. This inablity to detect EOF happens when either a - * 16-bit app or the 32-bit app is the listener. - * - * 2. If a 16-bit DOS application (detached or not) blocks when - * writing to a pipe, it will never wake up again, and it - * eventually brings the whole system down around it. - * - * The 16-bit application is run as a normal process inside - * of a hidden helper console app, and this helper may be run - * as a detached process. If any of the stdio handles is - * a pipe, the helper application accumulates information - * into temp files and forwards it to or from the DOS - * application as appropriate. This means that DOS apps - * must receive EOF from a stdin pipe before they will actually - * begin, and must finish generating stdout or stderr before - * the data will be sent to the next stage of the pipe. - * - * The helper app should be located in the same directory as - * the tcl dll. - */ - - if (createFlags != 0) { - startInfo.wShowWindow = SW_HIDE; - startInfo.dwFlags |= STARTF_USESHOWWINDOW; - createFlags = CREATE_NEW_CONSOLE; - } - Tcl_DStringAppend(&cmdLine, "tclpip" STRINGIFY(TCL_MAJOR_VERSION) - STRINGIFY(TCL_MINOR_VERSION) ".dll ", -1); - } - } - - /* - * cmdLine gets the full command line used to invoke the executable, - * including the name of the executable itself. The command line - * arguments in argv[] are stored in cmdLine separated by spaces. - * Special characters in individual arguments from argv[] must be - * quoted when being stored in cmdLine. - * - * When calling any application, bear in mind that arguments that - * specify a path name are not converted. If an argument contains - * forward slashes as path separators, it may or may not be - * recognized as a path name, depending on the program. In general, - * most applications accept forward slashes only as option - * delimiters and backslashes only as paths. - * - * Additionally, when calling a 16-bit dos or windows application, - * all path names must use the short, cryptic, path format (e.g., - * using ab~1.def instead of "a b.default"). - */ - - BuildCommandLine(execPath, argc, argv, &cmdLine); - - if ((*tclWinProcs->createProcessProc)(NULL, - (TCHAR *) Tcl_DStringValue(&cmdLine), NULL, NULL, TRUE, - createFlags, NULL, NULL, &startInfo, &procInfo) == 0) { - TclWinConvertError(GetLastError()); - Tcl_AppendResult(interp, "couldn't execute \"", argv[0], - "\": ", Tcl_PosixError(interp), (char *) NULL); - goto end; - } - - /* - * This wait is used to force the OS to give some time to the DOS - * process. - */ - - if (applType == APPL_DOS) { - WaitForSingleObject(procInfo.hProcess, 50); - } - - /* - * "When an application spawns a process repeatedly, a new thread - * instance will be created for each process but the previous - * instances may not be cleaned up. This results in a significant - * virtual memory loss each time the process is spawned. If there - * is a WaitForInputIdle() call between CreateProcess() and - * CloseHandle(), the problem does not occur." PSS ID Number: Q124121 - */ - - WaitForInputIdle(procInfo.hProcess, 5000); - CloseHandle(procInfo.hThread); - - *pidPtr = (Tcl_Pid) procInfo.hProcess; - if (*pidPtr != 0) { - TclWinAddProcess(procInfo.hProcess, procInfo.dwProcessId); - } - result = TCL_OK; - - end: - Tcl_DStringFree(&cmdLine); - if (startInfo.hStdInput != INVALID_HANDLE_VALUE) { - CloseHandle(startInfo.hStdInput); - } - if (startInfo.hStdOutput != INVALID_HANDLE_VALUE) { - CloseHandle(startInfo.hStdOutput); - } - if (startInfo.hStdError != INVALID_HANDLE_VALUE) { - CloseHandle(startInfo.hStdError); - } - return result; -} - - -/* - *---------------------------------------------------------------------- - * - * HasConsole -- - * - * Determines whether the current application is attached to a - * console. - * - * Results: - * Returns TRUE if this application has a console, else FALSE. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static BOOL -HasConsole() -{ - HANDLE handle; - - handle = CreateFileA("CONOUT$", GENERIC_WRITE, FILE_SHARE_WRITE, - NULL, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, NULL); - - if (handle != INVALID_HANDLE_VALUE) { - CloseHandle(handle); - return TRUE; - } else { - return FALSE; - } -} - -/* - *-------------------------------------------------------------------- - * - * ApplicationType -- - * - * Search for the specified program and identify if it refers to a DOS, - * Windows 3.X, or Win32 program. Used to determine how to invoke - * a program, or if it can even be invoked. - * - * It is possible to almost positively identify DOS and Windows - * applications that contain the appropriate magic numbers. However, - * DOS .com files do not seem to contain a magic number; if the program - * name ends with .com and could not be identified as a Windows .com - * file, it will be assumed to be a DOS application, even if it was - * just random data. If the program name does not end with .com, no - * such assumption is made. - * - * The Win32 procedure GetBinaryType incorrectly identifies any - * junk file that ends with .exe as a dos executable and some - * executables that don't end with .exe as not executable. Plus it - * doesn't exist under win95, so I won't feel bad about reimplementing - * functionality. - * - * Results: - * The return value is one of APPL_DOS, APPL_WIN3X, or APPL_WIN32 - * if the filename referred to the corresponding application type. - * If the file name could not be found or did not refer to any known - * application type, APPL_NONE is returned and an error message is - * left in interp. .bat files are identified as APPL_DOS. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -ApplicationType(interp, originalName, fullName) - Tcl_Interp *interp; /* Interp, for error message. */ - const char *originalName; /* Name of the application to find. */ - char fullName[]; /* Filled with complete path to - * application. */ -{ - int applType, i, nameLen, found; - HANDLE hFile; - TCHAR *rest; - char *ext; - char buf[2]; - DWORD attr, read; - IMAGE_DOS_HEADER header; - Tcl_DString nameBuf, ds; - TCHAR *nativeName; - WCHAR nativeFullPath[MAX_PATH]; - static char extensions[][5] = {"", ".com", ".exe", ".bat"}; - - /* Look for the program as an external program. First try the name - * as it is, then try adding .com, .exe, and .bat, in that order, to - * the name, looking for an executable. - * - * Using the raw SearchPath() procedure doesn't do quite what is - * necessary. If the name of the executable already contains a '.' - * character, it will not try appending the specified extension when - * searching (in other words, SearchPath will not find the program - * "a.b.exe" if the arguments specified "a.b" and ".exe"). - * So, first look for the file as it is named. Then manually append - * the extensions, looking for a match. - */ - - applType = APPL_NONE; - Tcl_DStringInit(&nameBuf); - Tcl_DStringAppend(&nameBuf, originalName, -1); - nameLen = Tcl_DStringLength(&nameBuf); - - for (i = 0; i < (int) (sizeof(extensions) / sizeof(extensions[0])); i++) { - Tcl_DStringSetLength(&nameBuf, nameLen); - Tcl_DStringAppend(&nameBuf, extensions[i], -1); - nativeName = Tcl_WinUtfToTChar(Tcl_DStringValue(&nameBuf), - Tcl_DStringLength(&nameBuf), &ds); - found = (*tclWinProcs->searchPathProc)(NULL, nativeName, NULL, - MAX_PATH, nativeFullPath, &rest); - Tcl_DStringFree(&ds); - if (found == 0) { - continue; - } - - /* - * Ignore matches on directories or data files, return if identified - * a known type. - */ - - attr = (*tclWinProcs->getFileAttributesProc)((TCHAR *) nativeFullPath); - if ((attr == 0xffffffff) || (attr & FILE_ATTRIBUTE_DIRECTORY)) { - continue; - } - strcpy(fullName, Tcl_WinTCharToUtf((TCHAR *) nativeFullPath, -1, &ds)); - Tcl_DStringFree(&ds); - - ext = strrchr(fullName, '.'); - if ((ext != NULL) && (stricmp(ext, ".bat") == 0)) { - applType = APPL_DOS; - break; - } - - hFile = (*tclWinProcs->createFileProc)((TCHAR *) nativeFullPath, - GENERIC_READ, FILE_SHARE_READ, NULL, OPEN_EXISTING, - FILE_ATTRIBUTE_NORMAL, NULL); - if (hFile == INVALID_HANDLE_VALUE) { - continue; - } - - header.e_magic = 0; - ReadFile(hFile, (void *) &header, sizeof(header), &read, NULL); - if (header.e_magic != IMAGE_DOS_SIGNATURE) { - /* - * Doesn't have the magic number for relocatable executables. If - * filename ends with .com, assume it's a DOS application anyhow. - * Note that we didn't make this assumption at first, because some - * supposed .com files are really 32-bit executables with all the - * magic numbers and everything. - */ - - CloseHandle(hFile); - if ((ext != NULL) && (strcmp(ext, ".com") == 0)) { - applType = APPL_DOS; - break; - } - continue; - } - if (header.e_lfarlc != sizeof(header)) { - /* - * All Windows 3.X and Win32 and some DOS programs have this value - * set here. If it doesn't, assume that since it already had the - * other magic number it was a DOS application. - */ - - CloseHandle(hFile); - applType = APPL_DOS; - break; - } - - /* - * The DWORD at header.e_lfanew points to yet another magic number. - */ - - buf[0] = '\0'; - SetFilePointer(hFile, header.e_lfanew, NULL, FILE_BEGIN); - ReadFile(hFile, (void *) buf, 2, &read, NULL); - CloseHandle(hFile); - - if ((buf[0] == 'N') && (buf[1] == 'E')) { - applType = APPL_WIN3X; - } else if ((buf[0] == 'P') && (buf[1] == 'E')) { - applType = APPL_WIN32; - } else { - /* - * Strictly speaking, there should be a test that there - * is an 'L' and 'E' at buf[0..1], to identify the type as - * DOS, but of course we ran into a DOS executable that - * _doesn't_ have the magic number -- specifically, one - * compiled using the Lahey Fortran90 compiler. - */ - - applType = APPL_DOS; - } - break; - } - Tcl_DStringFree(&nameBuf); - - if (applType == APPL_NONE) { - TclWinConvertError(GetLastError()); - Tcl_AppendResult(interp, "couldn't execute \"", originalName, - "\": ", Tcl_PosixError(interp), (char *) NULL); - return APPL_NONE; - } - - if ((applType == APPL_DOS) || (applType == APPL_WIN3X)) { - /* - * Replace long path name of executable with short path name for - * 16-bit applications. Otherwise the application may not be able - * to correctly parse its own command line to separate off the - * application name from the arguments. - */ - - (*tclWinProcs->getShortPathNameProc)((TCHAR *) nativeFullPath, - nativeFullPath, MAX_PATH); - strcpy(fullName, Tcl_WinTCharToUtf((TCHAR *) nativeFullPath, -1, &ds)); - Tcl_DStringFree(&ds); - } - return applType; -} - -/* - *---------------------------------------------------------------------- - * - * BuildCommandLine -- - * - * The command line arguments are stored in linePtr separated - * by spaces, in a form that CreateProcess() understands. Special - * characters in individual arguments from argv[] must be quoted - * when being stored in cmdLine. - * - * Results: - * None. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static void -BuildCommandLine( - CONST char *executable, /* Full path of executable (including - * extension). Replacement for argv[0]. */ - int argc, /* Number of arguments. */ - char **argv, /* Argument strings in UTF. */ - Tcl_DString *linePtr) /* Initialized Tcl_DString that receives the - * command line (TCHAR). */ -{ - CONST char *arg, *start, *special; - int quote, i; - Tcl_DString ds; - - Tcl_DStringInit(&ds); - - /* - * Prime the path. - */ - - Tcl_DStringAppend(&ds, Tcl_DStringValue(linePtr), -1); - - for (i = 0; i < argc; i++) { - if (i == 0) { - arg = executable; - } else { - arg = argv[i]; - Tcl_DStringAppend(&ds, " ", 1); - } - - quote = 0; - if (argv[i][0] == '\0') { - quote = 1; - } else { - for (start = argv[i]; *start != '\0'; start++) { - if (isspace(*start)) { /* INTL: ISO space. */ - quote = 1; - break; - } - } - } - if (quote) { - Tcl_DStringAppend(&ds, "\"", 1); - } - - start = arg; - for (special = arg; ; ) { - if ((*special == '\\') && - (special[1] == '\\' || special[1] == '"')) { - Tcl_DStringAppend(&ds, start, special - start); - start = special; - while (1) { - special++; - if (*special == '"') { - /* - * N backslashes followed a quote -> insert - * N * 2 + 1 backslashes then a quote. - */ - - Tcl_DStringAppend(&ds, start, special - start); - break; - } - if (*special != '\\') { - break; - } - } - Tcl_DStringAppend(&ds, start, special - start); - start = special; - } - if (*special == '"') { - Tcl_DStringAppend(&ds, start, special - start); - Tcl_DStringAppend(&ds, "\\\"", 2); - start = special + 1; - } - if (*special == '\0') { - break; - } - special++; - } - Tcl_DStringAppend(&ds, start, special - start); - if (quote) { - Tcl_DStringAppend(&ds, "\"", 1); - } - } - Tcl_WinUtfToTChar(Tcl_DStringValue(&ds), Tcl_DStringLength(&ds), linePtr); - Tcl_DStringFree(&ds); -} - -/* - *---------------------------------------------------------------------- - * - * TclpCreateCommandChannel -- - * - * This function is called by Tcl_OpenCommandChannel to perform - * the platform specific channel initialization for a command - * channel. - * - * Results: - * Returns a new channel or NULL on failure. - * - * Side effects: - * Allocates a new channel. - * - *---------------------------------------------------------------------- - */ - -Tcl_Channel -TclpCreateCommandChannel( - TclFile readFile, /* If non-null, gives the file for reading. */ - TclFile writeFile, /* If non-null, gives the file for writing. */ - TclFile errorFile, /* If non-null, gives the file where errors - * can be read. */ - int numPids, /* The number of pids in the pid array. */ - Tcl_Pid *pidPtr) /* An array of process identifiers. */ -{ - char channelName[16 + TCL_INTEGER_SPACE]; - int channelId; - DWORD id; - PipeInfo *infoPtr = (PipeInfo *) ckalloc((unsigned) sizeof(PipeInfo)); - - PipeInit(); - - infoPtr->watchMask = 0; - infoPtr->flags = 0; - infoPtr->readFlags = 0; - infoPtr->readFile = readFile; - infoPtr->writeFile = writeFile; - infoPtr->errorFile = errorFile; - infoPtr->numPids = numPids; - infoPtr->pidPtr = pidPtr; - infoPtr->writeBuf = 0; - infoPtr->writeBufLen = 0; - infoPtr->writeError = 0; - - /* - * Use one of the fds associated with the channel as the - * channel id. - */ - - if (readFile) { - channelId = (int) ((WinFile*)readFile)->handle; - } else if (writeFile) { - channelId = (int) ((WinFile*)writeFile)->handle; - } else if (errorFile) { - channelId = (int) ((WinFile*)errorFile)->handle; - } else { - channelId = 0; - } - - infoPtr->validMask = 0; - - infoPtr->threadId = Tcl_GetCurrentThread(); - - if (readFile != NULL) { - /* - * Start the background reader thread. - */ - - infoPtr->readable = CreateEvent(NULL, TRUE, TRUE, NULL); - infoPtr->startReader = CreateEvent(NULL, FALSE, FALSE, NULL); - infoPtr->readThread = CreateThread(NULL, 8000, PipeReaderThread, - infoPtr, 0, &id); - SetThreadPriority(infoPtr->readThread, THREAD_PRIORITY_HIGHEST); - infoPtr->validMask |= TCL_READABLE; - } else { - infoPtr->readThread = 0; - } - if (writeFile != NULL) { - /* - * Start the background writeer thwrite. - */ - - infoPtr->writable = CreateEvent(NULL, TRUE, TRUE, NULL); - infoPtr->startWriter = CreateEvent(NULL, FALSE, FALSE, NULL); - infoPtr->writeThread = CreateThread(NULL, 8000, PipeWriterThread, - infoPtr, 0, &id); - SetThreadPriority(infoPtr->readThread, THREAD_PRIORITY_HIGHEST); - infoPtr->validMask |= TCL_WRITABLE; - } - - /* - * For backward compatibility with previous versions of Tcl, we - * use "file%d" as the base name for pipes even though it would - * be more natural to use "pipe%d". - * Use the pointer to keep the channel names unique, in case - * channels share handles (stdin/stdout). - */ - - wsprintfA(channelName, "file%lx", infoPtr); - infoPtr->channel = Tcl_CreateChannel(&pipeChannelType, channelName, - (ClientData) infoPtr, infoPtr->validMask); - - /* - * Pipes have AUTO translation mode on Windows and ^Z eof char, which - * means that a ^Z will be appended to them at close. This is needed - * for Windows programs that expect a ^Z at EOF. - */ - - Tcl_SetChannelOption((Tcl_Interp *) NULL, infoPtr->channel, - "-translation", "auto"); - Tcl_SetChannelOption((Tcl_Interp *) NULL, infoPtr->channel, - "-eofchar", "\032 {}"); - return infoPtr->channel; -} - -/* - *---------------------------------------------------------------------- - * - * TclGetAndDetachPids -- - * - * Stores a list of the command PIDs for a command channel in - * the interp's result. - * - * Results: - * None. - * - * Side effects: - * Modifies the interp's result. - * - *---------------------------------------------------------------------- - */ - -void -TclGetAndDetachPids( - Tcl_Interp *interp, - Tcl_Channel chan) -{ - PipeInfo *pipePtr; - Tcl_ChannelType *chanTypePtr; - int i; - char buf[TCL_INTEGER_SPACE]; - - /* - * Punt if the channel is not a command channel. - */ - - chanTypePtr = Tcl_GetChannelType(chan); - if (chanTypePtr != &pipeChannelType) { - return; - } - - pipePtr = (PipeInfo *) Tcl_GetChannelInstanceData(chan); - for (i = 0; i < pipePtr->numPids; i++) { - wsprintfA(buf, "%lu", TclpGetPid(pipePtr->pidPtr[i])); - Tcl_AppendElement(interp, buf); - Tcl_DetachPids(1, &(pipePtr->pidPtr[i])); - } - if (pipePtr->numPids > 0) { - ckfree((char *) pipePtr->pidPtr); - pipePtr->numPids = 0; - } -} - -/* - *---------------------------------------------------------------------- - * - * PipeBlockModeProc -- - * - * Set blocking or non-blocking mode on channel. - * - * Results: - * 0 if successful, errno when failed. - * - * Side effects: - * Sets the device into blocking or non-blocking mode. - * - *---------------------------------------------------------------------- - */ - -static int -PipeBlockModeProc( - ClientData instanceData, /* Instance data for channel. */ - int mode) /* TCL_MODE_BLOCKING or - * TCL_MODE_NONBLOCKING. */ -{ - PipeInfo *infoPtr = (PipeInfo *) instanceData; - - /* - * Pipes on Windows can not be switched between blocking and nonblocking, - * hence we have to emulate the behavior. This is done in the input - * function by checking against a bit in the state. We set or unset the - * bit here to cause the input function to emulate the correct behavior. - */ - - if (mode == TCL_MODE_NONBLOCKING) { - infoPtr->flags |= PIPE_ASYNC; - } else { - infoPtr->flags &= ~(PIPE_ASYNC); - } - return 0; -} - -/* - *---------------------------------------------------------------------- - * - * PipeClose2Proc -- - * - * Closes a pipe based IO channel. - * - * Results: - * 0 on success, errno otherwise. - * - * Side effects: - * Closes the physical channel. - * - *---------------------------------------------------------------------- - */ - -static int -PipeClose2Proc( - ClientData instanceData, /* Pointer to PipeInfo structure. */ - Tcl_Interp *interp, /* For error reporting. */ - int flags) /* Flags that indicate which side to close. */ -{ - PipeInfo *pipePtr = (PipeInfo *) instanceData; - Tcl_Channel errChan; - int errorCode, result; - PipeInfo *infoPtr, **nextPtrPtr; - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - - errorCode = 0; - if ((!flags || (flags == TCL_CLOSE_READ)) - && (pipePtr->readFile != NULL)) { - /* - * Clean up the background thread if necessary. Note that this - * must be done before we can close the file, since the - * thread may be blocking trying to read from the pipe. - */ - - if (pipePtr->readThread) { - /* - * Forcibly terminate the background thread. We cannot rely on the - * thread to cleanly terminate itself because we have no way of - * closing the pipe handle without blocking in the case where the - * thread is in the middle of an I/O operation. Note that we need - * to guard against terminating the thread while it is in the - * middle of Tcl_ThreadAlert because it won't be able to release - * the notifier lock. - */ - - Tcl_MutexLock(&pipeMutex); - TerminateThread(pipePtr->readThread, 0); - - /* - * Wait for the thread to terminate. This ensures that we are - * completely cleaned up before we leave this function. - */ - - WaitForSingleObject(pipePtr->readThread, INFINITE); - Tcl_MutexUnlock(&pipeMutex); - - CloseHandle(pipePtr->readThread); - CloseHandle(pipePtr->readable); - CloseHandle(pipePtr->startReader); - pipePtr->readThread = NULL; - } - if (TclpCloseFile(pipePtr->readFile) != 0) { - errorCode = errno; - } - pipePtr->validMask &= ~TCL_READABLE; - pipePtr->readFile = NULL; - } - if ((!flags || (flags & TCL_CLOSE_WRITE)) - && (pipePtr->writeFile != NULL)) { - /* - * Wait for the writer thread to finish the current buffer, then - * terminate the thread and close the handles. If the channel is - * nonblocking, there should be no pending write operations. - */ - - if (pipePtr->writeThread) { - WaitForSingleObject(pipePtr->writable, INFINITE); - - /* - * Forcibly terminate the background thread. We cannot rely on the - * thread to cleanly terminate itself because we have no way of - * closing the pipe handle without blocking in the case where the - * thread is in the middle of an I/O operation. Note that we need - * to guard against terminating the thread while it is in the - * middle of Tcl_ThreadAlert because it won't be able to release - * the notifier lock. - */ - - Tcl_MutexLock(&pipeMutex); - TerminateThread(pipePtr->writeThread, 0); - - /* - * Wait for the thread to terminate. This ensures that we are - * completely cleaned up before we leave this function. - */ - - WaitForSingleObject(pipePtr->writeThread, INFINITE); - Tcl_MutexUnlock(&pipeMutex); - - - CloseHandle(pipePtr->writeThread); - CloseHandle(pipePtr->writable); - CloseHandle(pipePtr->startWriter); - pipePtr->writeThread = NULL; - } - if (TclpCloseFile(pipePtr->writeFile) != 0) { - if (errorCode == 0) { - errorCode = errno; - } - } - pipePtr->validMask &= ~TCL_WRITABLE; - pipePtr->writeFile = NULL; - } - - pipePtr->watchMask &= pipePtr->validMask; - - /* - * Don't free the channel if any of the flags were set. - */ - - if (flags) { - return errorCode; - } - - /* - * Remove the file from the list of watched files. - */ - - for (nextPtrPtr = &(tsdPtr->firstPipePtr), infoPtr = *nextPtrPtr; - infoPtr != NULL; - nextPtrPtr = &infoPtr->nextPtr, infoPtr = *nextPtrPtr) { - if (infoPtr == (PipeInfo *)pipePtr) { - *nextPtrPtr = infoPtr->nextPtr; - break; - } - } - - /* - * Wrap the error file into a channel and give it to the cleanup - * routine. - */ - - if (pipePtr->errorFile) { - WinFile *filePtr; - - filePtr = (WinFile*)pipePtr->errorFile; - errChan = Tcl_MakeFileChannel((ClientData) filePtr->handle, - TCL_READABLE); - ckfree((char *) filePtr); - } else { - errChan = NULL; - } - - result = TclCleanupChildren(interp, pipePtr->numPids, pipePtr->pidPtr, - errChan); - - if (pipePtr->numPids > 0) { - ckfree((char *) pipePtr->pidPtr); - } - - if (pipePtr->writeBuf != NULL) { - ckfree(pipePtr->writeBuf); - } - - ckfree((char*) pipePtr); - - if (errorCode == 0) { - return result; - } - return errorCode; -} - -/* - *---------------------------------------------------------------------- - * - * PipeInputProc -- - * - * Reads input from the IO channel into the buffer given. Returns - * count of how many bytes were actually read, and an error indication. - * - * Results: - * A count of how many bytes were read is returned and an error - * indication is returned in an output argument. - * - * Side effects: - * Reads input from the actual channel. - * - *---------------------------------------------------------------------- - */ - -static int -PipeInputProc( - ClientData instanceData, /* Pipe state. */ - char *buf, /* Where to store data read. */ - int bufSize, /* How much space is available - * in the buffer? */ - int *errorCode) /* Where to store error code. */ -{ - PipeInfo *infoPtr = (PipeInfo *) instanceData; - WinFile *filePtr = (WinFile*) infoPtr->readFile; - DWORD count, bytesRead = 0; - int result; - - *errorCode = 0; - /* - * Synchronize with the reader thread. - */ - - result = WaitForRead(infoPtr, (infoPtr->flags & PIPE_ASYNC) ? 0 : 1); - - /* - * If an error occurred, return immediately. - */ - - if (result == -1) { - *errorCode = errno; - return -1; - } - - if (infoPtr->readFlags & PIPE_EXTRABYTE) { - /* - * The reader thread consumed 1 byte as a side effect of - * waiting so we need to move it into the buffer. - */ - - *buf = infoPtr->extraByte; - infoPtr->readFlags &= ~PIPE_EXTRABYTE; - buf++; - bufSize--; - bytesRead = 1; - - /* - * If further read attempts would block, return what we have. - */ - - if (result == 0) { - return bytesRead; - } - } - - /* - * Attempt to read bufSize bytes. The read will return immediately - * if there is any data available. Otherwise it will block until - * at least one byte is available or an EOF occurs. - */ - - if (ReadFile(filePtr->handle, (LPVOID) buf, (DWORD) bufSize, &count, - (LPOVERLAPPED) NULL) == TRUE) { - return bytesRead + count; - } else if (bytesRead) { - /* - * Ignore errors if we have data to return. - */ - - return bytesRead; - } - - TclWinConvertError(GetLastError()); - if (errno == EPIPE) { - infoPtr->readFlags |= PIPE_EOF; - return 0; - } - *errorCode = errno; - return -1; -} - -/* - *---------------------------------------------------------------------- - * - * PipeOutputProc -- - * - * Writes the given output on the IO channel. Returns count of how - * many characters were actually written, and an error indication. - * - * Results: - * A count of how many characters were written is returned and an - * error indication is returned in an output argument. - * - * Side effects: - * Writes output on the actual channel. - * - *---------------------------------------------------------------------- - */ - -static int -PipeOutputProc( - ClientData instanceData, /* Pipe state. */ - char *buf, /* The data buffer. */ - int toWrite, /* How many bytes to write? */ - int *errorCode) /* Where to store error code. */ -{ - PipeInfo *infoPtr = (PipeInfo *) instanceData; - WinFile *filePtr = (WinFile*) infoPtr->writeFile; - DWORD bytesWritten, timeout; - - *errorCode = 0; - timeout = (infoPtr->flags & PIPE_ASYNC) ? 0 : INFINITE; - if (WaitForSingleObject(infoPtr->writable, timeout) == WAIT_TIMEOUT) { - /* - * The writer thread is blocked waiting for a write to complete - * and the channel is in non-blocking mode. - */ - - errno = EAGAIN; - goto error; - } - - /* - * Check for a background error on the last write. - */ - - if (infoPtr->writeError) { - TclWinConvertError(infoPtr->writeError); - infoPtr->writeError = 0; - goto error; - } - - if (infoPtr->flags & PIPE_ASYNC) { - /* - * The pipe is non-blocking, so copy the data into the output - * buffer and restart the writer thread. - */ - - if (toWrite > infoPtr->writeBufLen) { - /* - * Reallocate the buffer to be large enough to hold the data. - */ - - if (infoPtr->writeBuf) { - ckfree(infoPtr->writeBuf); - } - infoPtr->writeBufLen = toWrite; - infoPtr->writeBuf = ckalloc(toWrite); - } - memcpy(infoPtr->writeBuf, buf, toWrite); - infoPtr->toWrite = toWrite; - ResetEvent(infoPtr->writable); - SetEvent(infoPtr->startWriter); - bytesWritten = toWrite; - } else { - /* - * In the blocking case, just try to write the buffer directly. - * This avoids an unnecessary copy. - */ - - if (WriteFile(filePtr->handle, (LPVOID) buf, (DWORD) toWrite, - &bytesWritten, (LPOVERLAPPED) NULL) == FALSE) { - TclWinConvertError(GetLastError()); - goto error; - } - } - return bytesWritten; - - error: - *errorCode = errno; - return -1; - -} - -/* - *---------------------------------------------------------------------- - * - * PipeEventProc -- - * - * This function is invoked by Tcl_ServiceEvent when a file event - * reaches the front of the event queue. This procedure invokes - * Tcl_NotifyChannel on the pipe. - * - * Results: - * Returns 1 if the event was handled, meaning it should be removed - * from the queue. Returns 0 if the event was not handled, meaning - * it should stay on the queue. The only time the event isn't - * handled is if the TCL_FILE_EVENTS flag bit isn't set. - * - * Side effects: - * Whatever the notifier callback does. - * - *---------------------------------------------------------------------- - */ - -static int -PipeEventProc( - Tcl_Event *evPtr, /* Event to service. */ - int flags) /* Flags that indicate what events to - * handle, such as TCL_FILE_EVENTS. */ -{ - PipeEvent *pipeEvPtr = (PipeEvent *)evPtr; - PipeInfo *infoPtr; - WinFile *filePtr; - int mask; - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - - if (!(flags & TCL_FILE_EVENTS)) { - return 0; - } - - /* - * Search through the list of watched pipes for the one whose handle - * matches the event. We do this rather than simply dereferencing - * the handle in the event so that pipes can be deleted while the - * event is in the queue. - */ - - for (infoPtr = tsdPtr->firstPipePtr; infoPtr != NULL; - infoPtr = infoPtr->nextPtr) { - if (pipeEvPtr->infoPtr == infoPtr) { - infoPtr->flags &= ~(PIPE_PENDING); - break; - } - } - - /* - * Remove stale events. - */ - - if (!infoPtr) { - return 1; - } - - /* - * Check to see if the pipe is readable. Note - * that we can't tell if a pipe is writable, so we always report it - * as being writable unless we have detected EOF. - */ - - filePtr = (WinFile*) ((PipeInfo*)infoPtr)->writeFile; - mask = 0; - if ((infoPtr->watchMask & TCL_WRITABLE) && - (WaitForSingleObject(infoPtr->writable, 0) != WAIT_TIMEOUT)) { - mask = TCL_WRITABLE; - } - - filePtr = (WinFile*) ((PipeInfo*)infoPtr)->readFile; - if ((infoPtr->watchMask & TCL_READABLE) && - (WaitForRead(infoPtr, 0) >= 0)) { - if (infoPtr->readFlags & PIPE_EOF) { - mask = TCL_READABLE; - } else { - mask |= TCL_READABLE; - } - } - - /* - * Inform the channel of the events. - */ - - Tcl_NotifyChannel(infoPtr->channel, infoPtr->watchMask & mask); - return 1; -} - -/* - *---------------------------------------------------------------------- - * - * PipeWatchProc -- - * - * Called by the notifier to set up to watch for events on this - * channel. - * - * Results: - * None. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static void -PipeWatchProc( - ClientData instanceData, /* Pipe state. */ - int mask) /* What events to watch for, OR-ed - * combination of TCL_READABLE, - * TCL_WRITABLE and TCL_EXCEPTION. */ -{ - PipeInfo **nextPtrPtr, *ptr; - PipeInfo *infoPtr = (PipeInfo *) instanceData; - int oldMask = infoPtr->watchMask; - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - - /* - * Since most of the work is handled by the background threads, - * we just need to update the watchMask and then force the notifier - * to poll once. - */ - - infoPtr->watchMask = mask & infoPtr->validMask; - if (infoPtr->watchMask) { - Tcl_Time blockTime = { 0, 0 }; - if (!oldMask) { - infoPtr->nextPtr = tsdPtr->firstPipePtr; - tsdPtr->firstPipePtr = infoPtr; - } - Tcl_SetMaxBlockTime(&blockTime); - } else { - if (oldMask) { - /* - * Remove the pipe from the list of watched pipes. - */ - - for (nextPtrPtr = &(tsdPtr->firstPipePtr), ptr = *nextPtrPtr; - ptr != NULL; - nextPtrPtr = &ptr->nextPtr, ptr = *nextPtrPtr) { - if (infoPtr == ptr) { - *nextPtrPtr = ptr->nextPtr; - break; - } - } - } - } -} - -/* - *---------------------------------------------------------------------- - * - * PipeGetHandleProc -- - * - * Called from Tcl_GetChannelHandle to retrieve OS handles from - * inside a command pipeline based channel. - * - * Results: - * Returns TCL_OK with the fd in handlePtr, or TCL_ERROR if - * there is no handle for the specified direction. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -PipeGetHandleProc( - ClientData instanceData, /* The pipe state. */ - int direction, /* TCL_READABLE or TCL_WRITABLE */ - ClientData *handlePtr) /* Where to store the handle. */ -{ - PipeInfo *infoPtr = (PipeInfo *) instanceData; - WinFile *filePtr; - - if (direction == TCL_READABLE && infoPtr->readFile) { - filePtr = (WinFile*) infoPtr->readFile; - *handlePtr = (ClientData) filePtr->handle; - return TCL_OK; - } - if (direction == TCL_WRITABLE && infoPtr->writeFile) { - filePtr = (WinFile*) infoPtr->writeFile; - *handlePtr = (ClientData) filePtr->handle; - return TCL_OK; - } - return TCL_ERROR; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_WaitPid -- - * - * Emulates the waitpid system call. - * - * Results: - * Returns 0 if the process is still alive, -1 on an error, or - * the pid on a clean close. - * - * Side effects: - * Unless WNOHANG is set and the wait times out, the process - * information record will be deleted and the process handle - * will be closed. - * - *---------------------------------------------------------------------- - */ - -Tcl_Pid -Tcl_WaitPid( - Tcl_Pid pid, - int *statPtr, - int options) -{ - ProcInfo *infoPtr, **prevPtrPtr; - int flags; - Tcl_Pid result; - DWORD ret; - - PipeInit(); - - /* - * If no pid is specified, do nothing. - */ - - if (pid == 0) { - *statPtr = 0; - return 0; - } - - /* - * Find the process on the process list. - */ - - Tcl_MutexLock(&pipeMutex); - prevPtrPtr = &procList; - for (infoPtr = procList; infoPtr != NULL; - prevPtrPtr = &infoPtr->nextPtr, infoPtr = infoPtr->nextPtr) { - if (infoPtr->hProcess == (HANDLE) pid) { - break; - } - } - Tcl_MutexUnlock(&pipeMutex); - - /* - * If the pid is not one of the processes we know about (we started it) - * then do nothing. - */ - - if (infoPtr == NULL) { - *statPtr = 0; - return 0; - } - - /* - * Officially "wait" for it to finish. We either poll (WNOHANG) or - * wait for an infinite amount of time. - */ - - if (options & WNOHANG) { - flags = 0; - } else { - flags = INFINITE; - } - ret = WaitForSingleObject(infoPtr->hProcess, flags); - if (ret == WAIT_TIMEOUT) { - *statPtr = 0; - if (options & WNOHANG) { - return 0; - } else { - result = 0; - } - } else if (ret != WAIT_FAILED) { - GetExitCodeProcess(infoPtr->hProcess, (DWORD*)statPtr); - *statPtr = ((*statPtr << 8) & 0xff00); - result = pid; - } else { - errno = ECHILD; - *statPtr = ECHILD; - result = (Tcl_Pid) -1; - } - - /* - * Remove the process from the process list and close the process handle. - */ - - CloseHandle(infoPtr->hProcess); - *prevPtrPtr = infoPtr->nextPtr; - ckfree((char*)infoPtr); - - return result; -} - -/* - *---------------------------------------------------------------------- - * - * TclWinAddProcess -- - * - * Add a process to the process list so that we can use - * Tcl_WaitPid on the process. - * - * Results: - * None - * - * Side effects: - * Adds the specified process handle to the process list so - * Tcl_WaitPid knows about it. - * - *---------------------------------------------------------------------- - */ - -void -TclWinAddProcess(hProcess, id) - HANDLE hProcess; /* Handle to process */ - DWORD id; /* Global process identifier */ -{ - ProcInfo *procPtr = (ProcInfo *) ckalloc(sizeof(ProcInfo)); - procPtr->hProcess = hProcess; - procPtr->dwProcessId = id; - Tcl_MutexLock(&pipeMutex); - procPtr->nextPtr = procList; - procList = procPtr; - Tcl_MutexUnlock(&pipeMutex); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_PidObjCmd -- - * - * This procedure is invoked to process the "pid" Tcl command. - * See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -int -Tcl_PidObjCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *CONST *objv) /* Argument strings. */ -{ - Tcl_Channel chan; - Tcl_ChannelType *chanTypePtr; - PipeInfo *pipePtr; - int i; - Tcl_Obj *resultPtr; - char buf[TCL_INTEGER_SPACE]; - - if (objc > 2) { - Tcl_WrongNumArgs(interp, 1, objv, "?channelId?"); - return TCL_ERROR; - } - if (objc == 1) { - resultPtr = Tcl_GetObjResult(interp); - wsprintfA(buf, "%lu", (unsigned long) getpid()); - Tcl_SetStringObj(resultPtr, buf, -1); - } else { - chan = Tcl_GetChannel(interp, Tcl_GetStringFromObj(objv[1], NULL), - NULL); - if (chan == (Tcl_Channel) NULL) { - return TCL_ERROR; - } - chanTypePtr = Tcl_GetChannelType(chan); - if (chanTypePtr != &pipeChannelType) { - return TCL_OK; - } - - pipePtr = (PipeInfo *) Tcl_GetChannelInstanceData(chan); - resultPtr = Tcl_GetObjResult(interp); - for (i = 0; i < pipePtr->numPids; i++) { - wsprintfA(buf, "%lu", TclpGetPid(pipePtr->pidPtr[i])); - Tcl_ListObjAppendElement(/*interp*/ NULL, resultPtr, - Tcl_NewStringObj(buf, -1)); - } - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * WaitForRead -- - * - * Wait until some data is available, the pipe is at - * EOF or the reader thread is blocked waiting for data (if the - * channel is in non-blocking mode). - * - * Results: - * Returns 1 if pipe is readable. Returns 0 if there is no data - * on the pipe, but there is buffered data. Returns -1 if an - * error occurred. If an error occurred, the threads may not - * be synchronized. - * - * Side effects: - * Updates the shared state flags and may consume 1 byte of data - * from the pipe. If no error occurred, the reader thread is - * blocked waiting for a signal from the main thread. - * - *---------------------------------------------------------------------- - */ - -static int -WaitForRead( - PipeInfo *infoPtr, /* Pipe state. */ - int blocking) /* Indicates whether call should be - * blocking or not. */ -{ - DWORD timeout, count; - HANDLE *handle = ((WinFile *) infoPtr->readFile)->handle; - - while (1) { - /* - * Synchronize with the reader thread. - */ - - timeout = blocking ? INFINITE : 0; - if (WaitForSingleObject(infoPtr->readable, timeout) == WAIT_TIMEOUT) { - /* - * The reader thread is blocked waiting for data and the channel - * is in non-blocking mode. - */ - - errno = EAGAIN; - return -1; - } - - /* - * At this point, the two threads are synchronized, so it is safe - * to access shared state. - */ - - - /* - * If the pipe has hit EOF, it is always readable. - */ - - if (infoPtr->readFlags & PIPE_EOF) { - return 1; - } - - /* - * Check to see if there is any data sitting in the pipe. - */ - - if (PeekNamedPipe(handle, (LPVOID) NULL, (DWORD) 0, - (LPDWORD) NULL, &count, (LPDWORD) NULL) != TRUE) { - TclWinConvertError(GetLastError()); - /* - * Check to see if the peek failed because of EOF. - */ - - if (errno == EPIPE) { - infoPtr->readFlags |= PIPE_EOF; - return 1; - } - - /* - * Ignore errors if there is data in the buffer. - */ - - if (infoPtr->readFlags & PIPE_EXTRABYTE) { - return 0; - } else { - return -1; - } - } - - /* - * We found some data in the pipe, so it must be readable. - */ - - if (count > 0) { - return 1; - } - - /* - * The pipe isn't readable, but there is some data sitting - * in the buffer, so return immediately. - */ - - if (infoPtr->readFlags & PIPE_EXTRABYTE) { - return 0; - } - - /* - * There wasn't any data available, so reset the thread and - * try again. - */ - - ResetEvent(infoPtr->readable); - SetEvent(infoPtr->startReader); - } -} - -/* - *---------------------------------------------------------------------- - * - * PipeReaderThread -- - * - * This function runs in a separate thread and waits for input - * to become available on a pipe. - * - * Results: - * None. - * - * Side effects: - * Signals the main thread when input become available. May - * cause the main thread to wake up by posting a message. May - * consume one byte from the pipe for each wait operation. - * - *---------------------------------------------------------------------- - */ - -static DWORD WINAPI -PipeReaderThread(LPVOID arg) -{ - PipeInfo *infoPtr = (PipeInfo *)arg; - HANDLE *handle = ((WinFile *) infoPtr->readFile)->handle; - DWORD count, err; - int done = 0; - - while (!done) { - /* - * Wait for the main thread to signal before attempting to wait. - */ - - WaitForSingleObject(infoPtr->startReader, INFINITE); - - /* - * Try waiting for 0 bytes. This will block until some data is - * available on NT, but will return immediately on Win 95. So, - * if no data is available after the first read, we block until - * we can read a single byte off of the pipe. - */ - - if ((ReadFile(handle, NULL, 0, &count, NULL) == FALSE) - || (PeekNamedPipe(handle, NULL, 0, NULL, &count, - NULL) == FALSE)) { - /* - * The error is a result of an EOF condition, so set the - * EOF bit before signalling the main thread. - */ - - err = GetLastError(); - if (err == ERROR_BROKEN_PIPE) { - infoPtr->readFlags |= PIPE_EOF; - done = 1; - } else if (err == ERROR_INVALID_HANDLE) { - break; - } - } else if (count == 0) { - if (ReadFile(handle, &(infoPtr->extraByte), 1, &count, NULL) - != FALSE) { - /* - * One byte was consumed as a side effect of waiting - * for the pipe to become readable. - */ - - infoPtr->readFlags |= PIPE_EXTRABYTE; - } else { - err = GetLastError(); - if (err == ERROR_BROKEN_PIPE) { - /* - * The error is a result of an EOF condition, so set the - * EOF bit before signalling the main thread. - */ - - infoPtr->readFlags |= PIPE_EOF; - done = 1; - } else if (err == ERROR_INVALID_HANDLE) { - break; - } - } - } - - - /* - * Signal the main thread by signalling the readable event and - * then waking up the notifier thread. - */ - - SetEvent(infoPtr->readable); - - /* - * Alert the foreground thread. Note that we need to treat this like - * a critical section so the foreground thread does not terminate - * this thread while we are holding a mutex in the notifier code. - */ - - Tcl_MutexLock(&pipeMutex); - Tcl_ThreadAlert(infoPtr->threadId); - Tcl_MutexUnlock(&pipeMutex); - } - return 0; -} - -/* - *---------------------------------------------------------------------- - * - * PipeWriterThread -- - * - * This function runs in a separate thread and writes data - * onto a pipe. - * - * Results: - * Always returns 0. - * - * Side effects: - * Signals the main thread when an output operation is completed. - * May cause the main thread to wake up by posting a message. - * - *---------------------------------------------------------------------- - */ - -static DWORD WINAPI -PipeWriterThread(LPVOID arg) -{ - - PipeInfo *infoPtr = (PipeInfo *)arg; - HANDLE *handle = ((WinFile *) infoPtr->writeFile)->handle; - DWORD count, toWrite; - char *buf; - int done = 0; - - while (!done) { - /* - * Wait for the main thread to signal before attempting to write. - */ - - WaitForSingleObject(infoPtr->startWriter, INFINITE); - - buf = infoPtr->writeBuf; - toWrite = infoPtr->toWrite; - - /* - * Loop until all of the bytes are written or an error occurs. - */ - - while (toWrite > 0) { - if (WriteFile(handle, buf, toWrite, &count, NULL) == FALSE) { - infoPtr->writeError = GetLastError(); - done = 1; - break; - } else { - toWrite -= count; - buf += count; - } - } - - /* - * Signal the main thread by signalling the writable event and - * then waking up the notifier thread. - */ - - SetEvent(infoPtr->writable); - - /* - * Alert the foreground thread. Note that we need to treat this like - * a critical section so the foreground thread does not terminate - * this thread while we are holding a mutex in the notifier code. - */ - - Tcl_MutexLock(&pipeMutex); - Tcl_ThreadAlert(infoPtr->threadId); - Tcl_MutexUnlock(&pipeMutex); - } - return 0; -} - diff --git a/win/tclWinPort.h b/win/tclWinPort.h deleted file mode 100644 index a40681c..0000000 --- a/win/tclWinPort.h +++ /dev/null @@ -1,454 +0,0 @@ -/* - * tclWinPort.h -- - * - * This header file handles porting issues that occur because of - * differences between Windows and Unix. It should be the only - * file that contains #ifdefs to handle different flavors of OS. - * - * Copyright (c) 1994-1997 Sun Microsystems, Inc. - * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclWinPort.h,v 1.12 2000/03/31 08:52:31 hobbs Exp $ - */ - -#ifndef _TCLWINPORT -#define _TCLWINPORT - -#ifndef _TCLINT -# include "tclInt.h" -#endif - -#ifdef CHECK_UNICODE_CALLS - -#define _UNICODE -#define UNICODE - -#define __TCHAR_DEFINED -typedef float *_TCHAR; - -#define _TCHAR_DEFINED -typedef float *TCHAR; - -#endif - -/* - *--------------------------------------------------------------------------- - * The following sets of #includes and #ifdefs are required to get Tcl to - * compile under the windows compilers. - *--------------------------------------------------------------------------- - */ - -#include <stdio.h> -#include <stdlib.h> - -#include <direct.h> -#include <errno.h> -#include <fcntl.h> -#include <float.h> -#include <io.h> -#include <malloc.h> -#include <process.h> -#include <signal.h> -#include <string.h> - -/* - * Need to block out these includes for building extensions with MetroWerks - * compiler for Win32. - */ - -#ifndef __MWERKS__ -#include <sys/stat.h> -#include <sys/timeb.h> -#include <sys/utime.h> -#endif - -#include <tchar.h> -#include <time.h> -#include <winsock2.h> - -#define WIN32_LEAN_AND_MEAN -#include <windows.h> -#undef WIN32_LEAN_AND_MEAN - -#ifdef BUILD_tcl -# undef TCL_STORAGE_CLASS -# define TCL_STORAGE_CLASS DLLEXPORT -#endif - -/* - * Define EINPROGRESS in terms of WSAEINPROGRESS. - */ - -#ifndef EINPROGRESS -#define EINPROGRESS WSAEINPROGRESS -#endif - -/* - * If ENOTSUP is not defined, define it to a value that will never occur. - */ - -#ifndef ENOTSUP -#define ENOTSUP -1030507 -#endif - -/* - * The following defines redefine the Windows Socket errors as - * BSD errors so Tcl_PosixError can do the right thing. - */ - -#ifndef EWOULDBLOCK -#define EWOULDBLOCK EAGAIN -#endif -#ifndef EALREADY -#define EALREADY 149 /* operation already in progress */ -#endif -#ifndef ENOTSOCK -#define ENOTSOCK 95 /* Socket operation on non-socket */ -#endif -#ifndef EDESTADDRREQ -#define EDESTADDRREQ 96 /* Destination address required */ -#endif -#ifndef EMSGSIZE -#define EMSGSIZE 97 /* Message too long */ -#endif -#ifndef EPROTOTYPE -#define EPROTOTYPE 98 /* Protocol wrong type for socket */ -#endif -#ifndef ENOPROTOOPT -#define ENOPROTOOPT 99 /* Protocol not available */ -#endif -#ifndef EPROTONOSUPPORT -#define EPROTONOSUPPORT 120 /* Protocol not supported */ -#endif -#ifndef ESOCKTNOSUPPORT -#define ESOCKTNOSUPPORT 121 /* Socket type not supported */ -#endif -#ifndef EOPNOTSUPP -#define EOPNOTSUPP 122 /* Operation not supported on socket */ -#endif -#ifndef EPFNOSUPPORT -#define EPFNOSUPPORT 123 /* Protocol family not supported */ -#endif -#ifndef EAFNOSUPPORT -#define EAFNOSUPPORT 124 /* Address family not supported */ -#endif -#ifndef EADDRINUSE -#define EADDRINUSE 125 /* Address already in use */ -#endif -#ifndef EADDRNOTAVAIL -#define EADDRNOTAVAIL 126 /* Can't assign requested address */ -#endif -#ifndef ENETDOWN -#define ENETDOWN 127 /* Network is down */ -#endif -#ifndef ENETUNREACH -#define ENETUNREACH 128 /* Network is unreachable */ -#endif -#ifndef ENETRESET -#define ENETRESET 129 /* Network dropped connection on reset */ -#endif -#ifndef ECONNABORTED -#define ECONNABORTED 130 /* Software caused connection abort */ -#endif -#ifndef ECONNRESET -#define ECONNRESET 131 /* Connection reset by peer */ -#endif -#ifndef ENOBUFS -#define ENOBUFS 132 /* No buffer space available */ -#endif -#ifndef EISCONN -#define EISCONN 133 /* Socket is already connected */ -#endif -#ifndef ENOTCONN -#define ENOTCONN 134 /* Socket is not connected */ -#endif -#ifndef ESHUTDOWN -#define ESHUTDOWN 143 /* Can't send after socket shutdown */ -#endif -#ifndef ETOOMANYREFS -#define ETOOMANYREFS 144 /* Too many references: can't splice */ -#endif -#ifndef ETIMEDOUT -#define ETIMEDOUT 145 /* Connection timed out */ -#endif -#ifndef ECONNREFUSED -#define ECONNREFUSED 146 /* Connection refused */ -#endif -#ifndef ELOOP -#define ELOOP 90 /* Symbolic link loop */ -#endif -#ifndef EHOSTDOWN -#define EHOSTDOWN 147 /* Host is down */ -#endif -#ifndef EHOSTUNREACH -#define EHOSTUNREACH 148 /* No route to host */ -#endif -#ifndef ENOTEMPTY -#define ENOTEMPTY 93 /* directory not empty */ -#endif -#ifndef EUSERS -#define EUSERS 94 /* Too many users (for UFS) */ -#endif -#ifndef EDQUOT -#define EDQUOT 49 /* Disc quota exceeded */ -#endif -#ifndef ESTALE -#define ESTALE 151 /* Stale NFS file handle */ -#endif -#ifndef EREMOTE -#define EREMOTE 66 /* The object is remote */ -#endif - -/* - * Supply definitions for macros to query wait status, if not already - * defined in header files above. - */ - -#if TCL_UNION_WAIT -# define WAIT_STATUS_TYPE union wait -#else -# define WAIT_STATUS_TYPE int -#endif - -#ifndef WIFEXITED -# define WIFEXITED(stat) (((*((int *) &(stat))) & 0xff) == 0) -#endif - -#ifndef WEXITSTATUS -# define WEXITSTATUS(stat) (((*((int *) &(stat))) >> 8) & 0xff) -#endif - -#ifndef WIFSIGNALED -# define WIFSIGNALED(stat) (((*((int *) &(stat)))) && ((*((int *) &(stat))) == ((*((int *) &(stat))) & 0x00ff))) -#endif - -#ifndef WTERMSIG -# define WTERMSIG(stat) ((*((int *) &(stat))) & 0x7f) -#endif - -#ifndef WIFSTOPPED -# define WIFSTOPPED(stat) (((*((int *) &(stat))) & 0xff) == 0177) -#endif - -#ifndef WSTOPSIG -# define WSTOPSIG(stat) (((*((int *) &(stat))) >> 8) & 0xff) -#endif - -/* - * Define constants for waitpid() system call if they aren't defined - * by a system header file. - */ - -#ifndef WNOHANG -# define WNOHANG 1 -#endif -#ifndef WUNTRACED -# define WUNTRACED 2 -#endif - -/* - * Define access mode constants if they aren't already defined. - */ - -#ifndef F_OK -# define F_OK 00 -#endif -#ifndef X_OK -# define X_OK 01 -#endif -#ifndef W_OK -# define W_OK 02 -#endif -#ifndef R_OK -# define R_OK 04 -#endif - -/* - * Define macros to query file type bits, if they're not already - * defined. - */ - -#ifndef S_ISREG -# ifdef S_IFREG -# define S_ISREG(m) (((m) & S_IFMT) == S_IFREG) -# else -# define S_ISREG(m) 0 -# endif -# endif -#ifndef S_ISDIR -# ifdef S_IFDIR -# define S_ISDIR(m) (((m) & S_IFMT) == S_IFDIR) -# else -# define S_ISDIR(m) 0 -# endif -# endif -#ifndef S_ISCHR -# ifdef S_IFCHR -# define S_ISCHR(m) (((m) & S_IFMT) == S_IFCHR) -# else -# define S_ISCHR(m) 0 -# endif -# endif -#ifndef S_ISBLK -# ifdef S_IFBLK -# define S_ISBLK(m) (((m) & S_IFMT) == S_IFBLK) -# else -# define S_ISBLK(m) 0 -# endif -# endif -#ifndef S_ISFIFO -# ifdef S_IFIFO -# define S_ISFIFO(m) (((m) & S_IFMT) == S_IFIFO) -# else -# define S_ISFIFO(m) 0 -# endif -# endif - -/* - * Define MAXPATHLEN in terms of MAXPATH if available - */ - -#ifndef MAXPATH -#define MAXPATH MAX_PATH -#endif /* MAXPATH */ - -#ifndef MAXPATHLEN -#define MAXPATHLEN MAXPATH -#endif /* MAXPATHLEN */ - -/* - * Define pid_t and uid_t if they're not already defined. - */ - -#if ! TCL_PID_T -# define pid_t int -#endif -#if ! TCL_UID_T -# define uid_t int -#endif - -/* - * Visual C++ has some odd names for common functions, so we need to - * define a few macros to handle them. Also, it defines EDEADLOCK and - * EDEADLK as the same value, which confuses Tcl_ErrnoId(). - */ - -#if defined(_MSC_VER) || defined(__MINGW32__) -# define environ _environ -# define hypot _hypot -# define exception _exception -# undef EDEADLOCK -# if defined(__MINGW32__) && !defined(__MSVCRT__) -# define timezone _timezone -# endif -#endif /* _MSC_VER || __MINGW32__ */ - -/* - *--------------------------------------------------------------------------- - * The following macros and declarations represent the interface between - * generic and windows-specific parts of Tcl. Some of the macros may - * override functions declared in tclInt.h. - *--------------------------------------------------------------------------- - */ - -/* - * The default platform eol translation on Windows is TCL_TRANSLATE_CRLF: - */ - -#define TCL_PLATFORM_TRANSLATION TCL_TRANSLATE_CRLF - -/* - * Declare dynamic loading extension macro. - */ - -#define TCL_SHLIB_EXT ".dll" - -/* - * The following define ensures that we use the native putenv - * implementation to modify the environment array. This keeps - * the C level environment in synch with the system level environment. - */ - -#define USE_PUTENV 1 - -/* - * The following defines wrap the system memory allocation routines for - * use by tclAlloc.c. - */ - -#define TclpSysAlloc(size, isBin) ((void*)HeapAlloc(GetProcessHeap(), \ - (DWORD)0, (DWORD)size)) -#define TclpSysFree(ptr) (HeapFree(GetProcessHeap(), \ - (DWORD)0, (HGLOBAL)ptr)) -#define TclpSysRealloc(ptr, size) ((void*)HeapReAlloc(GetProcessHeap(), \ - (DWORD)0, (LPVOID)ptr, (DWORD)size)) - -/* - * The following defines map from standard socket names to our internal - * wrappers that redirect through the winSock function table (see the - * file tclWinSock.c). - */ - -#define getservbyname TclWinGetServByName -#define getsockopt TclWinGetSockOpt -#define ntohs TclWinNToHS -#define setsockopt TclWinSetSockOpt - -/* - * The following macros have trivial definitions, allowing generic code to - * address platform-specific issues. - */ - -#define TclpReleaseFile(file) ckfree((char *) file) - -/* - * The following macros and declarations wrap the C runtime library - * functions. - */ - -#define TclpExit exit -#define TclpLstat TclpStat - -/* - * Declarations for Windows-only functions. - */ - -EXTERN Tcl_Channel TclWinOpenSerialChannel _ANSI_ARGS_((HANDLE handle, - char *channelName, int permissions)); - -EXTERN Tcl_Channel TclWinOpenConsoleChannel _ANSI_ARGS_((HANDLE handle, - char *channelName, int permissions)); - -EXTERN Tcl_Channel TclWinOpenFileChannel _ANSI_ARGS_((HANDLE handle, - char *channelName, int permissions, int appendMode)); - -EXTERN TclFile TclWinMakeFile _ANSI_ARGS_((HANDLE handle)); - -/* - * Platform specific mutex definition used by memory allocators. - * These mutexes are statically allocated and explicitly initialized. - * Most modules do not use this, but instead use Tcl_Mutex types and - * Tcl_MutexLock and Tcl_MutexUnlock that are self-initializing. - */ - -#ifdef TCL_THREADS -typedef CRITICAL_SECTION TclpMutex; -EXTERN void TclpMutexInit _ANSI_ARGS_((TclpMutex *mPtr)); -EXTERN void TclpMutexLock _ANSI_ARGS_((TclpMutex *mPtr)); -EXTERN void TclpMutexUnlock _ANSI_ARGS_((TclpMutex *mPtr)); -#else -typedef int TclpMutex; -#define TclpMutexInit(a) -#define TclpMutexLock(a) -#define TclpMutexUnlock(a) -#endif /* TCL_THREADS */ - -#include "tclPlatDecls.h" -#include "tclIntPlatDecls.h" - -# undef TCL_STORAGE_CLASS -# define TCL_STORAGE_CLASS DLLIMPORT - -#endif /* _TCLWINPORT */ diff --git a/win/tclWinReg.c b/win/tclWinReg.c deleted file mode 100644 index e5808c2..0000000 --- a/win/tclWinReg.c +++ /dev/null @@ -1,1414 +0,0 @@ -/* - * tclWinReg.c -- - * - * This file contains the implementation of the "registry" Tcl - * built-in command. This command is built as a dynamically - * loadable extension in a separate DLL. - * - * Copyright (c) 1997 by Sun Microsystems, Inc. - * Copyright (c) 1998-1999 by Scriptics Corporation. - * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclWinReg.c,v 1.11 2000/03/31 08:52:32 hobbs Exp $ - */ - -#include <tclPort.h> -#include <stdlib.h> - -#define WIN32_LEAN_AND_MEAN -#include <windows.h> -#undef WIN32_LEAN_AND_MEAN - -/* - * TCL_STORAGE_CLASS is set unconditionally to DLLEXPORT because the - * Registry_Init declaration is in the source file itself, which is only - * accessed when we are building a library. - */ - -#undef TCL_STORAGE_CLASS -#define TCL_STORAGE_CLASS DLLEXPORT - -/* - * The following macros convert between different endian ints. - */ - -#define SWAPWORD(x) MAKEWORD(HIBYTE(x), LOBYTE(x)) -#define SWAPLONG(x) MAKELONG(SWAPWORD(HIWORD(x)), SWAPWORD(LOWORD(x))) - -/* - * The following flag is used in OpenKeys to indicate that the specified - * key should be created if it doesn't currently exist. - */ - -#define REG_CREATE 1 - -/* - * The following tables contain the mapping from registry root names - * to the system predefined keys. - */ - -static char *rootKeyNames[] = { - "HKEY_LOCAL_MACHINE", "HKEY_USERS", "HKEY_CLASSES_ROOT", - "HKEY_CURRENT_USER", "HKEY_CURRENT_CONFIG", - "HKEY_PERFORMANCE_DATA", "HKEY_DYN_DATA", NULL -}; - -static HKEY rootKeys[] = { - HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, - HKEY_CURRENT_CONFIG, HKEY_PERFORMANCE_DATA, HKEY_DYN_DATA -}; - -/* - * The following table maps from registry types to strings. Note that - * the indices for this array are the same as the constants for the - * known registry types so we don't need a separate table to hold the - * mapping. - */ - -static char *typeNames[] = { - "none", "sz", "expand_sz", "binary", "dword", - "dword_big_endian", "link", "multi_sz", "resource_list", NULL -}; - -static DWORD lastType = REG_RESOURCE_LIST; - -/* - * The following structures allow us to select between the Unicode and ASCII - * interfaces at run time based on whether Unicode APIs are available. The - * Unicode APIs are preferable because they will handle characters outside - * of the current code page. - */ - -typedef struct RegWinProcs { - int useWide; - - LONG (WINAPI *regConnectRegistryProc)(TCHAR *, HKEY, PHKEY); - LONG (WINAPI *regCreateKeyExProc)(HKEY, CONST TCHAR *, DWORD, TCHAR *, - DWORD, REGSAM, SECURITY_ATTRIBUTES *, HKEY *, DWORD *); - LONG (WINAPI *regDeleteKeyProc)(HKEY, CONST TCHAR *); - LONG (WINAPI *regDeleteValueProc)(HKEY, CONST TCHAR *); - LONG (WINAPI *regEnumKeyProc)(HKEY, DWORD, TCHAR *, DWORD); - LONG (WINAPI *regEnumKeyExProc)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *, - TCHAR *, DWORD *, FILETIME *); - LONG (WINAPI *regEnumValueProc)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *, - DWORD *, BYTE *, DWORD *); - LONG (WINAPI *regOpenKeyExProc)(HKEY, CONST TCHAR *, DWORD, REGSAM, - HKEY *); - LONG (WINAPI *regQueryInfoKeyProc)(HKEY, TCHAR *, DWORD *, DWORD *, - DWORD *, DWORD *, DWORD *, DWORD *, DWORD *, DWORD *, DWORD *, - FILETIME *); - LONG (WINAPI *regQueryValueExProc)(HKEY, CONST TCHAR *, DWORD *, DWORD *, - BYTE *, DWORD *); - LONG (WINAPI *regSetValueExProc)(HKEY, CONST TCHAR *, DWORD, DWORD, - CONST BYTE*, DWORD); -} RegWinProcs; - -static RegWinProcs *regWinProcs; - -static RegWinProcs asciiProcs = { - 0, - - (LONG (WINAPI *)(TCHAR *, HKEY, PHKEY)) RegConnectRegistryA, - (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, TCHAR *, - DWORD, REGSAM, SECURITY_ATTRIBUTES *, HKEY *, - DWORD *)) RegCreateKeyExA, - (LONG (WINAPI *)(HKEY, CONST TCHAR *)) RegDeleteKeyA, - (LONG (WINAPI *)(HKEY, CONST TCHAR *)) RegDeleteValueA, - (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD)) RegEnumKeyA, - (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *, - TCHAR *, DWORD *, FILETIME *)) RegEnumKeyExA, - (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *, - DWORD *, BYTE *, DWORD *)) RegEnumValueA, - (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, REGSAM, - HKEY *)) RegOpenKeyExA, - (LONG (WINAPI *)(HKEY, TCHAR *, DWORD *, DWORD *, - DWORD *, DWORD *, DWORD *, DWORD *, DWORD *, DWORD *, DWORD *, - FILETIME *)) RegQueryInfoKeyA, - (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD *, DWORD *, - BYTE *, DWORD *)) RegQueryValueExA, - (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, DWORD, - CONST BYTE*, DWORD)) RegSetValueExA, -}; - -static RegWinProcs unicodeProcs = { - 1, - - (LONG (WINAPI *)(TCHAR *, HKEY, PHKEY)) RegConnectRegistryW, - (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, TCHAR *, - DWORD, REGSAM, SECURITY_ATTRIBUTES *, HKEY *, - DWORD *)) RegCreateKeyExW, - (LONG (WINAPI *)(HKEY, CONST TCHAR *)) RegDeleteKeyW, - (LONG (WINAPI *)(HKEY, CONST TCHAR *)) RegDeleteValueW, - (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD)) RegEnumKeyW, - (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *, - TCHAR *, DWORD *, FILETIME *)) RegEnumKeyExW, - (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *, - DWORD *, BYTE *, DWORD *)) RegEnumValueW, - (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, REGSAM, - HKEY *)) RegOpenKeyExW, - (LONG (WINAPI *)(HKEY, TCHAR *, DWORD *, DWORD *, - DWORD *, DWORD *, DWORD *, DWORD *, DWORD *, DWORD *, DWORD *, - FILETIME *)) RegQueryInfoKeyW, - (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD *, DWORD *, - BYTE *, DWORD *)) RegQueryValueExW, - (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, DWORD, - CONST BYTE*, DWORD)) RegSetValueExW, -}; - - -/* - * Declarations for functions defined in this file. - */ - -static void AppendSystemError(Tcl_Interp *interp, DWORD error); -static DWORD ConvertDWORD(DWORD type, DWORD value); -static int DeleteKey(Tcl_Interp *interp, Tcl_Obj *keyNameObj); -static int DeleteValue(Tcl_Interp *interp, Tcl_Obj *keyNameObj, - Tcl_Obj *valueNameObj); -static int GetKeyNames(Tcl_Interp *interp, Tcl_Obj *keyNameObj, - Tcl_Obj *patternObj); -static int GetType(Tcl_Interp *interp, Tcl_Obj *keyNameObj, - Tcl_Obj *valueNameObj); -static int GetValue(Tcl_Interp *interp, Tcl_Obj *keyNameObj, - Tcl_Obj *valueNameObj); -static int GetValueNames(Tcl_Interp *interp, Tcl_Obj *keyNameObj, - Tcl_Obj *patternObj); -static int OpenKey(Tcl_Interp *interp, Tcl_Obj *keyNameObj, - REGSAM mode, int flags, HKEY *keyPtr); -static DWORD OpenSubKey(char *hostName, HKEY rootKey, - char *keyName, REGSAM mode, int flags, - HKEY *keyPtr); -static int ParseKeyName(Tcl_Interp *interp, char *name, - char **hostNamePtr, HKEY *rootKeyPtr, - char **keyNamePtr); -static DWORD RecursiveDeleteKey(HKEY hStartKey, TCHAR * pKeyName); -static int RegistryObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj * CONST objv[]); -static int SetValue(Tcl_Interp *interp, Tcl_Obj *keyNameObj, - Tcl_Obj *valueNameObj, Tcl_Obj *dataObj, - Tcl_Obj *typeObj); - -EXTERN int Registry_Init(Tcl_Interp *interp); - -/* - *---------------------------------------------------------------------- - * - * Registry_Init -- - * - * This procedure initializes the registry command. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -Registry_Init( - Tcl_Interp *interp) -{ - if (!Tcl_InitStubs(interp, "8.0", 0)) { - return TCL_ERROR; - } - - /* - * Determine if the unicode interfaces are available and select the - * appropriate registry function table. - */ - - if (TclWinGetPlatformId() == VER_PLATFORM_WIN32_NT) { - regWinProcs = &unicodeProcs; - } else { - regWinProcs = &asciiProcs; - } - - Tcl_CreateObjCommand(interp, "registry", RegistryObjCmd, NULL, NULL); - return Tcl_PkgProvide(interp, "registry", "1.0"); -} - -/* - *---------------------------------------------------------------------- - * - * RegistryObjCmd -- - * - * This function implements the Tcl "registry" command. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -RegistryObjCmd( - ClientData clientData, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj * CONST objv[]) /* Argument values. */ -{ - int index; - char *errString; - - static char *subcommands[] = { "delete", "get", "keys", "set", "type", - "values", (char *) NULL }; - enum SubCmdIdx { DeleteIdx, GetIdx, KeysIdx, SetIdx, TypeIdx, ValuesIdx }; - - if (objc < 2) { - Tcl_WrongNumArgs(interp, objc, objv, "option ?arg arg ...?"); - return TCL_ERROR; - } - - if (Tcl_GetIndexFromObj(interp, objv[1], subcommands, "option", 0, &index) - != TCL_OK) { - return TCL_ERROR; - } - - switch (index) { - case DeleteIdx: /* delete */ - if (objc == 3) { - return DeleteKey(interp, objv[2]); - } else if (objc == 4) { - return DeleteValue(interp, objv[2], objv[3]); - } - errString = "keyName ?valueName?"; - break; - case GetIdx: /* get */ - if (objc == 4) { - return GetValue(interp, objv[2], objv[3]); - } - errString = "keyName valueName"; - break; - case KeysIdx: /* keys */ - if (objc == 3) { - return GetKeyNames(interp, objv[2], NULL); - } else if (objc == 4) { - return GetKeyNames(interp, objv[2], objv[3]); - } - errString = "keyName ?pattern?"; - break; - case SetIdx: /* set */ - if (objc == 3) { - HKEY key; - - /* - * Create the key and then close it immediately. - */ - - if (OpenKey(interp, objv[2], KEY_ALL_ACCESS, 1, &key) - != TCL_OK) { - return TCL_ERROR; - } - RegCloseKey(key); - return TCL_OK; - } else if (objc == 5 || objc == 6) { - Tcl_Obj *typeObj = (objc == 5) ? NULL : objv[5]; - return SetValue(interp, objv[2], objv[3], objv[4], typeObj); - } - errString = "keyName ?valueName data ?type??"; - break; - case TypeIdx: /* type */ - if (objc == 4) { - return GetType(interp, objv[2], objv[3]); - } - errString = "keyName valueName"; - break; - case ValuesIdx: /* values */ - if (objc == 3) { - return GetValueNames(interp, objv[2], NULL); - } else if (objc == 4) { - return GetValueNames(interp, objv[2], objv[3]); - } - errString = "keyName ?pattern?"; - break; - } - Tcl_WrongNumArgs(interp, 2, objv, errString); - return TCL_ERROR; -} - -/* - *---------------------------------------------------------------------- - * - * DeleteKey -- - * - * This function deletes a registry key. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -DeleteKey( - Tcl_Interp *interp, /* Current interpreter. */ - Tcl_Obj *keyNameObj) /* Name of key to delete. */ -{ - char *tail, *buffer, *hostName, *keyName; - HKEY rootKey, subkey; - DWORD result; - int length; - Tcl_Obj *resultPtr; - Tcl_DString buf; - - /* - * Find the parent of the key being deleted and open it. - */ - - keyName = Tcl_GetStringFromObj(keyNameObj, &length); - buffer = ckalloc(length + 1); - strcpy(buffer, keyName); - - if (ParseKeyName(interp, buffer, &hostName, &rootKey, &keyName) - != TCL_OK) { - ckfree(buffer); - return TCL_ERROR; - } - - resultPtr = Tcl_GetObjResult(interp); - if (*keyName == '\0') { - Tcl_AppendToObj(resultPtr, "bad key: cannot delete root keys", -1); - ckfree(buffer); - return TCL_ERROR; - } - - tail = strrchr(keyName, '\\'); - if (tail) { - *tail++ = '\0'; - } else { - tail = keyName; - keyName = NULL; - } - - result = OpenSubKey(hostName, rootKey, keyName, - KEY_ENUMERATE_SUB_KEYS | DELETE, 0, &subkey); - if (result != ERROR_SUCCESS) { - ckfree(buffer); - if (result == ERROR_FILE_NOT_FOUND) { - return TCL_OK; - } else { - Tcl_AppendToObj(resultPtr, "unable to delete key: ", -1); - AppendSystemError(interp, result); - return TCL_ERROR; - } - } - - /* - * Now we recursively delete the key and everything below it. - */ - - tail = Tcl_WinUtfToTChar(tail, -1, &buf); - result = RecursiveDeleteKey(subkey, tail); - Tcl_DStringFree(&buf); - - if (result != ERROR_SUCCESS && result != ERROR_FILE_NOT_FOUND) { - Tcl_AppendToObj(resultPtr, "unable to delete key: ", -1); - AppendSystemError(interp, result); - result = TCL_ERROR; - } else { - result = TCL_OK; - } - - RegCloseKey(subkey); - ckfree(buffer); - return result; -} - -/* - *---------------------------------------------------------------------- - * - * DeleteValue -- - * - * This function deletes a value from a registry key. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -DeleteValue( - Tcl_Interp *interp, /* Current interpreter. */ - Tcl_Obj *keyNameObj, /* Name of key. */ - Tcl_Obj *valueNameObj) /* Name of value to delete. */ -{ - HKEY key; - char *valueName; - int length; - DWORD result; - Tcl_Obj *resultPtr; - Tcl_DString ds; - - /* - * Attempt to open the key for deletion. - */ - - if (OpenKey(interp, keyNameObj, KEY_SET_VALUE, 0, &key) - != TCL_OK) { - return TCL_ERROR; - } - - resultPtr = Tcl_GetObjResult(interp); - valueName = Tcl_GetStringFromObj(valueNameObj, &length); - Tcl_WinUtfToTChar(valueName, length, &ds); - result = (*regWinProcs->regDeleteValueProc)(key, Tcl_DStringValue(&ds)); - Tcl_DStringFree(&ds); - if (result != ERROR_SUCCESS) { - Tcl_AppendStringsToObj(resultPtr, "unable to delete value \"", - Tcl_GetString(valueNameObj), "\" from key \"", - Tcl_GetString(keyNameObj), "\": ", NULL); - AppendSystemError(interp, result); - result = TCL_ERROR; - } else { - result = TCL_OK; - } - RegCloseKey(key); - return result; -} - -/* - *---------------------------------------------------------------------- - * - * GetKeyNames -- - * - * This function enumerates the subkeys of a given key. If the - * optional pattern is supplied, then only keys that match the - * pattern will be returned. - * - * Results: - * Returns the list of subkeys in the result object of the - * interpreter, or an error message on failure. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -GetKeyNames( - Tcl_Interp *interp, /* Current interpreter. */ - Tcl_Obj *keyNameObj, /* Key to enumerate. */ - Tcl_Obj *patternObj) /* Optional match pattern. */ -{ - HKEY key; - DWORD index; - char buffer[MAX_PATH+1], *pattern, *name; - Tcl_Obj *resultPtr; - int result = TCL_OK; - Tcl_DString ds; - - /* - * Attempt to open the key for enumeration. - */ - - if (OpenKey(interp, keyNameObj, KEY_ENUMERATE_SUB_KEYS, 0, &key) - != TCL_OK) { - return TCL_ERROR; - } - - if (patternObj) { - pattern = Tcl_GetString(patternObj); - } else { - pattern = NULL; - } - - /* - * Enumerate over the subkeys until we get an error, indicating the - * end of the list. - */ - - resultPtr = Tcl_GetObjResult(interp); - for (index = 0; (*regWinProcs->regEnumKeyProc)(key, index, buffer, - MAX_PATH+1) == ERROR_SUCCESS; index++) { - Tcl_WinTCharToUtf((TCHAR *) buffer, -1, &ds); - name = Tcl_DStringValue(&ds); - if (pattern && !Tcl_StringMatch(name, pattern)) { - Tcl_DStringFree(&ds); - continue; - } - result = Tcl_ListObjAppendElement(interp, resultPtr, - Tcl_NewStringObj(name, Tcl_DStringLength(&ds))); - Tcl_DStringFree(&ds); - if (result != TCL_OK) { - break; - } - } - - RegCloseKey(key); - return result; -} - -/* - *---------------------------------------------------------------------- - * - * GetType -- - * - * This function gets the type of a given registry value and - * places it in the interpreter result. - * - * Results: - * Returns a normal Tcl result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -GetType( - Tcl_Interp *interp, /* Current interpreter. */ - Tcl_Obj *keyNameObj, /* Name of key. */ - Tcl_Obj *valueNameObj) /* Name of value to get. */ -{ - HKEY key; - Tcl_Obj *resultPtr; - DWORD result; - DWORD type; - Tcl_DString ds; - char *valueName; - int length; - - /* - * Attempt to open the key for reading. - */ - - if (OpenKey(interp, keyNameObj, KEY_QUERY_VALUE, 0, &key) - != TCL_OK) { - return TCL_ERROR; - } - - /* - * Get the type of the value. - */ - - resultPtr = Tcl_GetObjResult(interp); - - valueName = Tcl_GetStringFromObj(valueNameObj, &length); - valueName = Tcl_WinUtfToTChar(valueName, length, &ds); - result = (*regWinProcs->regQueryValueExProc)(key, valueName, NULL, &type, - NULL, NULL); - Tcl_DStringFree(&ds); - RegCloseKey(key); - - if (result != ERROR_SUCCESS) { - Tcl_AppendStringsToObj(resultPtr, "unable to get type of value \"", - Tcl_GetString(valueNameObj), "\" from key \"", - Tcl_GetString(keyNameObj), "\": ", NULL); - AppendSystemError(interp, result); - return TCL_ERROR; - } - - /* - * Set the type into the result. Watch out for unknown types. - * If we don't know about the type, just use the numeric value. - */ - - if (type > lastType || type < 0) { - Tcl_SetIntObj(resultPtr, type); - } else { - Tcl_SetStringObj(resultPtr, typeNames[type], -1); - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * GetValue -- - * - * This function gets the contents of a registry value and places - * a list containing the data and the type in the interpreter - * result. - * - * Results: - * Returns a normal Tcl result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -GetValue( - Tcl_Interp *interp, /* Current interpreter. */ - Tcl_Obj *keyNameObj, /* Name of key. */ - Tcl_Obj *valueNameObj) /* Name of value to get. */ -{ - HKEY key; - char *valueName; - DWORD result, length, type; - Tcl_Obj *resultPtr; - Tcl_DString data, buf; - int nameLen; - - /* - * Attempt to open the key for reading. - */ - - if (OpenKey(interp, keyNameObj, KEY_QUERY_VALUE, 0, &key) - != TCL_OK) { - return TCL_ERROR; - } - - /* - * Initialize a Dstring to maximum statically allocated size - * we could get one more byte by avoiding Tcl_DStringSetLength() - * and just setting length to TCL_DSTRING_STATIC_SIZE, but this - * should be safer if the implementation of Dstrings changes. - * - * This allows short values to be read from the registy in one call. - * Longer values need a second call with an expanded DString. - */ - - Tcl_DStringInit(&data); - length = TCL_DSTRING_STATIC_SIZE - 1; - Tcl_DStringSetLength(&data, length); - - resultPtr = Tcl_GetObjResult(interp); - - valueName = Tcl_GetStringFromObj(valueNameObj, &nameLen); - valueName = Tcl_WinUtfToTChar(valueName, nameLen, &buf); - - result = (*regWinProcs->regQueryValueExProc)(key, valueName, NULL, &type, - (BYTE *) Tcl_DStringValue(&data), &length); - while (result == ERROR_MORE_DATA) { - /* - * The Windows docs say that in this error case, we just need - * to expand our buffer and request more data. - * Required for HKEY_PERFORMANCE_DATA - */ - length *= 2; - Tcl_DStringSetLength(&data, length); - result = (*regWinProcs->regQueryValueExProc)(key, valueName, NULL, - &type, (BYTE *) Tcl_DStringValue(&data), &length); - } - Tcl_DStringFree(&buf); - RegCloseKey(key); - if (result != ERROR_SUCCESS) { - Tcl_AppendStringsToObj(resultPtr, "unable to get value \"", - Tcl_GetString(valueNameObj), "\" from key \"", - Tcl_GetString(keyNameObj), "\": ", NULL); - AppendSystemError(interp, result); - Tcl_DStringFree(&data); - return TCL_ERROR; - } - - /* - * If the data is a 32-bit quantity, store it as an integer object. If it - * is a multi-string, store it as a list of strings. For null-terminated - * strings, append up the to first null. Otherwise, store it as a binary - * string. - */ - - if (type == REG_DWORD || type == REG_DWORD_BIG_ENDIAN) { - Tcl_SetIntObj(resultPtr, ConvertDWORD(type, - *((DWORD*) Tcl_DStringValue(&data)))); - } else if (type == REG_MULTI_SZ) { - char *p = Tcl_DStringValue(&data); - char *end = Tcl_DStringValue(&data) + length; - - /* - * Multistrings are stored as an array of null-terminated strings, - * terminated by two null characters. Also do a bounds check in - * case we get bogus data. - */ - - while (p < end && ((regWinProcs->useWide) - ? *((Tcl_UniChar *)p) : *p) != 0) { - Tcl_WinTCharToUtf((TCHAR *) p, -1, &buf); - Tcl_ListObjAppendElement(interp, resultPtr, - Tcl_NewStringObj(Tcl_DStringValue(&buf), - Tcl_DStringLength(&buf))); - if (regWinProcs->useWide) { - while (*((Tcl_UniChar *)p)++ != 0) {} - } else { - while (*p++ != '\0') {} - } - Tcl_DStringFree(&buf); - } - } else if ((type == REG_SZ) || (type == REG_EXPAND_SZ)) { - Tcl_WinTCharToUtf((TCHAR *) Tcl_DStringValue(&data), -1, &buf); - Tcl_SetStringObj(resultPtr, Tcl_DStringValue(&buf), - Tcl_DStringLength(&buf)); - Tcl_DStringFree(&buf); - } else { - /* - * Save binary data as a byte array. - */ - - Tcl_SetByteArrayObj(resultPtr, Tcl_DStringValue(&data), length); - } - Tcl_DStringFree(&data); - return result; -} - -/* - *---------------------------------------------------------------------- - * - * GetValueNames -- - * - * This function enumerates the values of the a given key. If - * the optional pattern is supplied, then only value names that - * match the pattern will be returned. - * - * Results: - * Returns the list of value names in the result object of the - * interpreter, or an error message on failure. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -GetValueNames( - Tcl_Interp *interp, /* Current interpreter. */ - Tcl_Obj *keyNameObj, /* Key to enumerate. */ - Tcl_Obj *patternObj) /* Optional match pattern. */ -{ - HKEY key; - Tcl_Obj *resultPtr; - DWORD index, size, maxSize, result; - Tcl_DString buffer, ds; - char *pattern, *name; - - /* - * Attempt to open the key for enumeration. - */ - - if (OpenKey(interp, keyNameObj, KEY_QUERY_VALUE, 0, &key) - != TCL_OK) { - return TCL_ERROR; - } - - resultPtr = Tcl_GetObjResult(interp); - - /* - * Query the key to determine the appropriate buffer size to hold the - * largest value name plus the terminating null. - */ - - result = (*regWinProcs->regQueryInfoKeyProc)(key, NULL, NULL, NULL, NULL, - NULL, NULL, &index, &maxSize, NULL, NULL, NULL); - if (result != ERROR_SUCCESS) { - Tcl_AppendStringsToObj(resultPtr, "unable to query key \"", - Tcl_GetString(keyNameObj), "\": ", NULL); - AppendSystemError(interp, result); - RegCloseKey(key); - result = TCL_ERROR; - goto done; - } - maxSize++; - - - Tcl_DStringInit(&buffer); - Tcl_DStringSetLength(&buffer, - (regWinProcs->useWide) ? maxSize*2 : maxSize); - index = 0; - result = TCL_OK; - - if (patternObj) { - pattern = Tcl_GetString(patternObj); - } else { - pattern = NULL; - } - - /* - * Enumerate the values under the given subkey until we get an error, - * indicating the end of the list. Note that we need to reset size - * after each iteration because RegEnumValue smashes the old value. - */ - - size = maxSize; - while ((*regWinProcs->regEnumValueProc)(key, index, - Tcl_DStringValue(&buffer), &size, NULL, NULL, NULL, NULL) - == ERROR_SUCCESS) { - - if (regWinProcs->useWide) { - size *= 2; - } - - Tcl_WinTCharToUtf((TCHAR *) Tcl_DStringValue(&buffer), size, &ds); - name = Tcl_DStringValue(&ds); - if (!pattern || Tcl_StringMatch(name, pattern)) { - result = Tcl_ListObjAppendElement(interp, resultPtr, - Tcl_NewStringObj(name, Tcl_DStringLength(&ds))); - if (result != TCL_OK) { - Tcl_DStringFree(&ds); - break; - } - } - Tcl_DStringFree(&ds); - - index++; - size = maxSize; - } - Tcl_DStringFree(&buffer); - - done: - RegCloseKey(key); - return result; -} - -/* - *---------------------------------------------------------------------- - * - * OpenKey -- - * - * This function opens the specified key. This function is a - * simple wrapper around ParseKeyName and OpenSubKey. - * - * Results: - * Returns the opened key in the keyPtr argument and a Tcl - * result code. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -OpenKey( - Tcl_Interp *interp, /* Current interpreter. */ - Tcl_Obj *keyNameObj, /* Key to open. */ - REGSAM mode, /* Access mode. */ - int flags, /* 0 or REG_CREATE. */ - HKEY *keyPtr) /* Returned HKEY. */ -{ - char *keyName, *buffer, *hostName; - int length; - HKEY rootKey; - DWORD result; - - keyName = Tcl_GetStringFromObj(keyNameObj, &length); - buffer = ckalloc(length + 1); - strcpy(buffer, keyName); - - result = ParseKeyName(interp, buffer, &hostName, &rootKey, &keyName); - if (result == TCL_OK) { - result = OpenSubKey(hostName, rootKey, keyName, mode, flags, keyPtr); - if (result != ERROR_SUCCESS) { - Tcl_Obj *resultPtr = Tcl_GetObjResult(interp); - Tcl_AppendToObj(resultPtr, "unable to open key: ", -1); - AppendSystemError(interp, result); - result = TCL_ERROR; - } else { - result = TCL_OK; - } - } - - ckfree(buffer); - return result; -} - -/* - *---------------------------------------------------------------------- - * - * OpenSubKey -- - * - * This function opens a given subkey of a root key on the - * specified host. - * - * Results: - * Returns the opened key in the keyPtr and a Windows error code - * as the return value. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static DWORD -OpenSubKey( - char *hostName, /* Host to access, or NULL for local. */ - HKEY rootKey, /* Root registry key. */ - char *keyName, /* Subkey name. */ - REGSAM mode, /* Access mode. */ - int flags, /* 0 or REG_CREATE. */ - HKEY *keyPtr) /* Returned HKEY. */ -{ - DWORD result; - Tcl_DString buf; - - /* - * Attempt to open the root key on a remote host if necessary. - */ - - if (hostName) { - hostName = Tcl_WinUtfToTChar(hostName, -1, &buf); - result = (*regWinProcs->regConnectRegistryProc)(hostName, rootKey, - &rootKey); - Tcl_DStringFree(&buf); - if (result != ERROR_SUCCESS) { - return result; - } - } - - /* - * Now open the specified key with the requested permissions. Note - * that this key must be closed by the caller. - */ - - keyName = Tcl_WinUtfToTChar(keyName, -1, &buf); - if (flags & REG_CREATE) { - DWORD create; - result = (*regWinProcs->regCreateKeyExProc)(rootKey, keyName, 0, "", - REG_OPTION_NON_VOLATILE, mode, NULL, keyPtr, &create); - } else { - if (rootKey == HKEY_PERFORMANCE_DATA) { - /* - * Here we fudge it for this special root key. - * See MSDN for more info on HKEY_PERFORMANCE_DATA and - * the peculiarities surrounding it - */ - *keyPtr = HKEY_PERFORMANCE_DATA; - result = ERROR_SUCCESS; - } else { - result = (*regWinProcs->regOpenKeyExProc)(rootKey, keyName, 0, - mode, keyPtr); - } - } - Tcl_DStringFree(&buf); - - /* - * Be sure to close the root key since we are done with it now. - */ - - if (hostName) { - RegCloseKey(rootKey); - } - return result; -} - -/* - *---------------------------------------------------------------------- - * - * ParseKeyName -- - * - * This function parses a key name into the host, root, and subkey - * parts. - * - * Results: - * The pointers to the start of the host and subkey names are - * returned in the hostNamePtr and keyNamePtr variables. The - * specified root HKEY is returned in rootKeyPtr. Returns - * a standard Tcl result. - * - * - * Side effects: - * Modifies the name string by inserting nulls. - * - *---------------------------------------------------------------------- - */ - -static int -ParseKeyName( - Tcl_Interp *interp, /* Current interpreter. */ - char *name, - char **hostNamePtr, - HKEY *rootKeyPtr, - char **keyNamePtr) -{ - char *rootName; - int result, index; - Tcl_Obj *rootObj, *resultPtr = Tcl_GetObjResult(interp); - - /* - * Split the key into host and root portions. - */ - - *hostNamePtr = *keyNamePtr = rootName = NULL; - if (name[0] == '\\') { - if (name[1] == '\\') { - *hostNamePtr = name; - for (rootName = name+2; *rootName != '\0'; rootName++) { - if (*rootName == '\\') { - *rootName++ = '\0'; - break; - } - } - } - } else { - rootName = name; - } - if (!rootName) { - Tcl_AppendStringsToObj(resultPtr, "bad key \"", name, - "\": must start with a valid root", NULL); - return TCL_ERROR; - } - - /* - * Split the root into root and subkey portions. - */ - - for (*keyNamePtr = rootName; **keyNamePtr != '\0'; (*keyNamePtr)++) { - if (**keyNamePtr == '\\') { - **keyNamePtr = '\0'; - (*keyNamePtr)++; - break; - } - } - - /* - * Look for a matching root name. - */ - - rootObj = Tcl_NewStringObj(rootName, -1); - result = Tcl_GetIndexFromObj(interp, rootObj, rootKeyNames, "root name", - TCL_EXACT, &index); - Tcl_DecrRefCount(rootObj); - if (result != TCL_OK) { - return TCL_ERROR; - } - *rootKeyPtr = rootKeys[index]; - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * RecursiveDeleteKey -- - * - * This function recursively deletes all the keys below a starting - * key. Although Windows 95 does this automatically, we still need - * to do this for Windows NT. - * - * Results: - * Returns a Windows error code. - * - * Side effects: - * Deletes all of the keys and values below the given key. - * - *---------------------------------------------------------------------- - */ - -static DWORD -RecursiveDeleteKey( - HKEY startKey, /* Parent of key to be deleted. */ - char *keyName) /* Name of key to be deleted in external - * encoding, not UTF. */ -{ - DWORD result, size, maxSize; - Tcl_DString subkey; - HKEY hKey; - - /* - * Do not allow NULL or empty key name. - */ - - if (!keyName || *keyName == '\0') { - return ERROR_BADKEY; - } - - result = (*regWinProcs->regOpenKeyExProc)(startKey, keyName, 0, - KEY_ENUMERATE_SUB_KEYS | DELETE | KEY_QUERY_VALUE, &hKey); - if (result != ERROR_SUCCESS) { - return result; - } - result = (*regWinProcs->regQueryInfoKeyProc)(hKey, NULL, NULL, NULL, NULL, - &maxSize, NULL, NULL, NULL, NULL, NULL, NULL); - maxSize++; - if (result != ERROR_SUCCESS) { - return result; - } - - Tcl_DStringInit(&subkey); - Tcl_DStringSetLength(&subkey, - (regWinProcs->useWide) ? maxSize * 2 : maxSize); - - while (result == ERROR_SUCCESS) { - /* - * Always get index 0 because key deletion changes ordering. - */ - - size = maxSize; - result=(*regWinProcs->regEnumKeyExProc)(hKey, 0, - Tcl_DStringValue(&subkey), &size, NULL, NULL, NULL, NULL); - if (result == ERROR_NO_MORE_ITEMS) { - result = (*regWinProcs->regDeleteKeyProc)(startKey, keyName); - break; - } else if (result == ERROR_SUCCESS) { - result = RecursiveDeleteKey(hKey, Tcl_DStringValue(&subkey)); - } - } - Tcl_DStringFree(&subkey); - RegCloseKey(hKey); - return result; -} - -/* - *---------------------------------------------------------------------- - * - * SetValue -- - * - * This function sets the contents of a registry value. If - * the key or value does not exist, it will be created. If it - * does exist, then the data and type will be replaced. - * - * Results: - * Returns a normal Tcl result. - * - * Side effects: - * May create new keys or values. - * - *---------------------------------------------------------------------- - */ - -static int -SetValue( - Tcl_Interp *interp, /* Current interpreter. */ - Tcl_Obj *keyNameObj, /* Name of key. */ - Tcl_Obj *valueNameObj, /* Name of value to set. */ - Tcl_Obj *dataObj, /* Data to be written. */ - Tcl_Obj *typeObj) /* Type of data to be written. */ -{ - DWORD type, result; - HKEY key; - int length; - char *valueName; - Tcl_Obj *resultPtr; - Tcl_DString nameBuf; - - if (typeObj == NULL) { - type = REG_SZ; - } else if (Tcl_GetIndexFromObj(interp, typeObj, typeNames, "type", - 0, (int *) &type) != TCL_OK) { - if (Tcl_GetIntFromObj(NULL, typeObj, (int*) &type) != TCL_OK) { - return TCL_ERROR; - } - Tcl_ResetResult(interp); - } - if (OpenKey(interp, keyNameObj, KEY_ALL_ACCESS, 1, &key) != TCL_OK) { - return TCL_ERROR; - } - - valueName = Tcl_GetStringFromObj(valueNameObj, &length); - valueName = Tcl_WinUtfToTChar(valueName, length, &nameBuf); - resultPtr = Tcl_GetObjResult(interp); - - if (type == REG_DWORD || type == REG_DWORD_BIG_ENDIAN) { - DWORD value; - if (Tcl_GetIntFromObj(interp, dataObj, (int*) &value) != TCL_OK) { - RegCloseKey(key); - Tcl_DStringFree(&nameBuf); - return TCL_ERROR; - } - - value = ConvertDWORD(type, value); - result = (*regWinProcs->regSetValueExProc)(key, valueName, 0, type, - (BYTE*) &value, sizeof(DWORD)); - } else if (type == REG_MULTI_SZ) { - Tcl_DString data, buf; - int objc, i; - Tcl_Obj **objv; - - if (Tcl_ListObjGetElements(interp, dataObj, &objc, &objv) != TCL_OK) { - RegCloseKey(key); - Tcl_DStringFree(&nameBuf); - return TCL_ERROR; - } - - /* - * Append the elements as null terminated strings. Note that - * we must not assume the length of the string in case there are - * embedded nulls, which aren't allowed in REG_MULTI_SZ values. - */ - - Tcl_DStringInit(&data); - for (i = 0; i < objc; i++) { - Tcl_DStringAppend(&data, Tcl_GetString(objv[i]), -1); - - /* - * Add a null character to separate this value from the next. - * We accomplish this by growing the string by one byte. Since the - * DString always tacks on an extra null byte, the new byte will - * already be set to null. - */ - - Tcl_DStringSetLength(&data, Tcl_DStringLength(&data)+1); - } - - Tcl_WinUtfToTChar(Tcl_DStringValue(&data), Tcl_DStringLength(&data)+1, - &buf); - result = (*regWinProcs->regSetValueExProc)(key, valueName, 0, type, - (BYTE *) Tcl_DStringValue(&buf), - (DWORD) Tcl_DStringLength(&buf)); - Tcl_DStringFree(&data); - Tcl_DStringFree(&buf); - } else if (type == REG_SZ || type == REG_EXPAND_SZ) { - Tcl_DString buf; - char *data = Tcl_GetStringFromObj(dataObj, &length); - - data = Tcl_WinUtfToTChar(data, length, &buf); - - /* - * Include the null in the length, padding if needed for Unicode. - */ - - if (regWinProcs->useWide) { - Tcl_DStringSetLength(&buf, Tcl_DStringLength(&buf)+1); - } - length = Tcl_DStringLength(&buf) + 1; - - result = (*regWinProcs->regSetValueExProc)(key, valueName, 0, type, - (BYTE*)data, length); - Tcl_DStringFree(&buf); - } else { - char *data; - - /* - * Store binary data in the registry. - */ - - data = Tcl_GetByteArrayFromObj(dataObj, &length); - result = (*regWinProcs->regSetValueExProc)(key, valueName, 0, type, - (BYTE *)data, length); - } - Tcl_DStringFree(&nameBuf); - RegCloseKey(key); - if (result != ERROR_SUCCESS) { - Tcl_AppendToObj(resultPtr, "unable to set value: ", -1); - AppendSystemError(interp, result); - return TCL_ERROR; - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * AppendSystemError -- - * - * This routine formats a Windows system error message and places - * it into the interpreter result. - * - * Results: - * None. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static void -AppendSystemError( - Tcl_Interp *interp, /* Current interpreter. */ - DWORD error) /* Result code from error. */ -{ - int length; - WCHAR *wMsgPtr; - char *msg; - char id[TCL_INTEGER_SPACE], msgBuf[24 + TCL_INTEGER_SPACE]; - Tcl_DString ds; - Tcl_Obj *resultPtr = Tcl_GetObjResult(interp); - - length = FormatMessageW(FORMAT_MESSAGE_FROM_SYSTEM - | FORMAT_MESSAGE_ALLOCATE_BUFFER, NULL, error, - MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), (WCHAR *) &wMsgPtr, - 0, NULL); - if (length == 0) { - char *msgPtr; - - length = FormatMessageA(FORMAT_MESSAGE_FROM_SYSTEM - | FORMAT_MESSAGE_ALLOCATE_BUFFER, NULL, error, - MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), (char *) &msgPtr, - 0, NULL); - if (length > 0) { - wMsgPtr = (WCHAR *) LocalAlloc(LPTR, (length + 1) * sizeof(WCHAR)); - MultiByteToWideChar(CP_ACP, 0, msgPtr, length + 1, wMsgPtr, - length + 1); - LocalFree(msgPtr); - } - } - if (length == 0) { - if (error == ERROR_CALL_NOT_IMPLEMENTED) { - msg = "function not supported under Win32s"; - } else { - sprintf(msgBuf, "unknown error: %d", error); - msg = msgBuf; - } - } else { - Tcl_Encoding encoding; - - encoding = Tcl_GetEncoding(NULL, "unicode"); - Tcl_ExternalToUtfDString(encoding, (char *) wMsgPtr, -1, &ds); - Tcl_FreeEncoding(encoding); - LocalFree(wMsgPtr); - - msg = Tcl_DStringValue(&ds); - length = Tcl_DStringLength(&ds); - - /* - * Trim the trailing CR/LF from the system message. - */ - if (msg[length-1] == '\n') { - msg[--length] = 0; - } - if (msg[length-1] == '\r') { - msg[--length] = 0; - } - } - - sprintf(id, "%d", error); - Tcl_SetErrorCode(interp, "WINDOWS", id, msg, (char *) NULL); - Tcl_AppendToObj(resultPtr, msg, length); - - if (length != 0) { - Tcl_DStringFree(&ds); - } -} - -/* - *---------------------------------------------------------------------- - * - * ConvertDWORD -- - * - * This function determines whether a DWORD needs to be byte - * swapped, and returns the appropriately swapped value. - * - * Results: - * Returns a converted DWORD. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static DWORD -ConvertDWORD( - DWORD type, /* Either REG_DWORD or REG_DWORD_BIG_ENDIAN */ - DWORD value) /* The value to be converted. */ -{ - DWORD order = 1; - DWORD localType; - - /* - * Check to see if the low bit is in the first byte. - */ - - localType = (*((char*)(&order)) == 1) ? REG_DWORD : REG_DWORD_BIG_ENDIAN; - return (type != localType) ? SWAPLONG(value) : value; -} diff --git a/win/tclWinSerial.c b/win/tclWinSerial.c deleted file mode 100644 index 8e1da0a..0000000 --- a/win/tclWinSerial.c +++ /dev/null @@ -1,1206 +0,0 @@ -/* - * Tclwinserial.c -- - * - * This file implements the Windows-specific serial port functions, - * and the "serial" channel driver. - * - * Copyright (c) 1999 by Scriptics Corp. - * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - * Changes by Rolf.Schroedter@dlr.de June 25-27, 1999 - * - * RCS: @(#) $Id: tclWinSerial.c,v 1.9.2.1 2000/07/27 01:39:26 hobbs Exp $ - */ - -#include "tclWinInt.h" - -#include <dos.h> -#include <fcntl.h> -#include <io.h> -#include <sys/stat.h> - -/* - * The following variable is used to tell whether this module has been - * initialized. - */ - -static int initialized = 0; - -/* - * Bit masks used in the flags field of the SerialInfo structure below. - */ - -#define SERIAL_PENDING (1<<0) /* Message is pending in the queue. */ -#define SERIAL_ASYNC (1<<1) /* Channel is non-blocking. */ - -/* - * Bit masks used in the sharedFlags field of the SerialInfo structure below. - */ - -#define SERIAL_EOF (1<<2) /* Serial has reached EOF. */ -#define SERIAL_ERROR (1<<4) -#define SERIAL_WRITE (1<<5) /* enables fileevent writable - * one time after write operation */ - -/* - * Default time to block between checking status on the serial port. - */ -#define SERIAL_DEFAULT_BLOCKTIME 10 /* 10 msec */ - -/* - * Define Win32 read/write error masks returned by ClearCommError() - */ -#define SERIAL_READ_ERRORS ( CE_RXOVER | CE_OVERRUN | CE_RXPARITY \ - | CE_FRAME | CE_BREAK ) -#define SERIAL_WRITE_ERRORS ( CE_TXFULL ) - -/* - * This structure describes per-instance data for a serial based channel. - */ - -typedef struct SerialInfo { - HANDLE handle; - struct SerialInfo *nextPtr; /* Pointer to next registered serial. */ - Tcl_Channel channel; /* Pointer to channel structure. */ - int validMask; /* OR'ed combination of TCL_READABLE, - * TCL_WRITABLE, or TCL_EXCEPTION: indicates - * which operations are valid on the file. */ - int watchMask; /* OR'ed combination of TCL_READABLE, - * TCL_WRITABLE, or TCL_EXCEPTION: indicates - * which events should be reported. */ - int flags; /* State flags, see above for a list. */ - int writable; /* flag that the channel is readable */ - int readable; /* flag that the channel is readable */ - int blockTime; /* max. blocktime in msec */ - DWORD error; /* pending error code returned by - * ClearCommError() */ - DWORD lastError; /* last error code, can be fetched with - * fconfigure chan -lasterror */ -} SerialInfo; - -typedef struct ThreadSpecificData { - /* - * The following pointer refers to the head of the list of serials - * that are being watched for file events. - */ - - SerialInfo *firstSerialPtr; -} ThreadSpecificData; - -static Tcl_ThreadDataKey dataKey; - -/* - * The following structure is what is added to the Tcl event queue when - * serial events are generated. - */ - -typedef struct SerialEvent { - Tcl_Event header; /* Information that is standard for - * all events. */ - SerialInfo *infoPtr; /* Pointer to serial info structure. Note - * that we still have to verify that the - * serial exists before dereferencing this - * pointer. */ -} SerialEvent; - -COMMTIMEOUTS timeout_sync = { /* Timouts for blocking mode */ - MAXDWORD, /* ReadIntervalTimeout */ - MAXDWORD, /* ReadTotalTimeoutMultiplier */ - MAXDWORD-1, /* ReadTotalTimeoutConstant, - MAXDWORD-1 works for both Win95/NT */ - 0, /* WriteTotalTimeoutMultiplier */ - 0, /* WriteTotalTimeoutConstant */ -}; - -COMMTIMEOUTS timeout_async = { /* Timouts for non-blocking mode */ - 0, /* ReadIntervalTimeout */ - 0, /* ReadTotalTimeoutMultiplier */ - 1, /* ReadTotalTimeoutConstant */ - 0, /* WriteTotalTimeoutMultiplier */ - 0, /* WriteTotalTimeoutConstant */ -}; - -/* - * Declarations for functions used only in this file. - */ - -static int SerialBlockProc(ClientData instanceData, int mode); -static void SerialCheckProc(ClientData clientData, int flags); -static int SerialCloseProc(ClientData instanceData, - Tcl_Interp *interp); -static int SerialEventProc(Tcl_Event *evPtr, int flags); -static void SerialExitHandler(ClientData clientData); -static int SerialGetHandleProc(ClientData instanceData, - int direction, ClientData *handlePtr); -static ThreadSpecificData *SerialInit(void); -static int SerialInputProc(ClientData instanceData, char *buf, - int toRead, int *errorCode); -static int SerialOutputProc(ClientData instanceData, char *buf, - int toWrite, int *errorCode); -static void SerialSetupProc(ClientData clientData, int flags); -static void SerialWatchProc(ClientData instanceData, int mask); -static void ProcExitHandler(ClientData clientData); -static int SerialGetOptionProc _ANSI_ARGS_((ClientData instanceData, - Tcl_Interp *interp, char *optionName, - Tcl_DString *dsPtr)); -static int SerialSetOptionProc _ANSI_ARGS_((ClientData instanceData, - Tcl_Interp *interp, char *optionName, - char *value)); - -/* - * This structure describes the channel type structure for command serial - * based IO. - */ - -static Tcl_ChannelType serialChannelType = { - "serial", /* Type name. */ - TCL_CHANNEL_VERSION_2, /* v2 channel */ - SerialCloseProc, /* Close proc. */ - SerialInputProc, /* Input proc. */ - SerialOutputProc, /* Output proc. */ - NULL, /* Seek proc. */ - SerialSetOptionProc, /* Set option proc. */ - SerialGetOptionProc, /* Get option proc. */ - SerialWatchProc, /* Set up notifier to watch the channel. */ - SerialGetHandleProc, /* Get an OS handle from channel. */ - NULL, /* close2proc. */ - SerialBlockProc, /* Set blocking or non-blocking mode.*/ - NULL, /* flush proc. */ - NULL, /* handler proc. */ -}; - -/* - *---------------------------------------------------------------------- - * - * SerialInit -- - * - * This function initializes the static variables for this file. - * - * Results: - * None. - * - * Side effects: - * Creates a new event source. - * - *---------------------------------------------------------------------- - */ - -static ThreadSpecificData * -SerialInit() -{ - ThreadSpecificData *tsdPtr; - - /* - * Check the initialized flag first, then check it again in the mutex. - * This is a speed enhancement. - */ - - if (!initialized) { - if (!initialized) { - initialized = 1; - Tcl_CreateExitHandler(ProcExitHandler, NULL); - } - } - - tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey); - if (tsdPtr == NULL) { - tsdPtr = TCL_TSD_INIT(&dataKey); - tsdPtr->firstSerialPtr = NULL; - Tcl_CreateEventSource(SerialSetupProc, SerialCheckProc, NULL); - Tcl_CreateThreadExitHandler(SerialExitHandler, NULL); - } - return tsdPtr; -} - -/* - *---------------------------------------------------------------------- - * - * SerialExitHandler -- - * - * This function is called to cleanup the serial module before - * Tcl is unloaded. - * - * Results: - * None. - * - * Side effects: - * Removes the serial event source. - * - *---------------------------------------------------------------------- - */ - -static void -SerialExitHandler( - ClientData clientData) /* Old window proc */ -{ - Tcl_DeleteEventSource(SerialSetupProc, SerialCheckProc, NULL); -} - -/* - *---------------------------------------------------------------------- - * - * ProcExitHandler -- - * - * This function is called to cleanup the process list before - * Tcl is unloaded. - * - * Results: - * None. - * - * Side effects: - * Resets the process list. - * - *---------------------------------------------------------------------- - */ - -static void -ProcExitHandler( - ClientData clientData) /* Old window proc */ -{ - initialized = 0; -} - -/* - *---------------------------------------------------------------------- - * - * SerialBlockTime -- - * - * Wrapper to set Tcl's block time in msec - * - * Results: - * None. - *---------------------------------------------------------------------- - */ - -void -SerialBlockTime( - int msec) /* milli-seconds */ -{ - Tcl_Time blockTime; - - blockTime.sec = msec / 1000; - blockTime.usec = (msec % 1000) * 1000; - Tcl_SetMaxBlockTime(&blockTime); -} -/* - *---------------------------------------------------------------------- - * - * SerialSetupProc -- - * - * This procedure is invoked before Tcl_DoOneEvent blocks waiting - * for an event. - * - * Results: - * None. - * - * Side effects: - * Adjusts the block time if needed. - * - *---------------------------------------------------------------------- - */ - -void -SerialSetupProc( - ClientData data, /* Not used. */ - int flags) /* Event flags as passed to Tcl_DoOneEvent. */ -{ - SerialInfo *infoPtr; - int block = 1; - int msec = INT_MAX; /* min. found block time */ - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - - if (!(flags & TCL_FILE_EVENTS)) { - return; - } - - /* - * Look to see if any events handlers installed. If they are, do not block. - */ - - for (infoPtr = tsdPtr->firstSerialPtr; infoPtr != NULL; - infoPtr = infoPtr->nextPtr) { - - if( infoPtr->watchMask & (TCL_WRITABLE | TCL_READABLE) ) { - block = 0; - msec = min( msec, infoPtr->blockTime ); - } - } - - if (!block) { - SerialBlockTime(msec); - } -} - -/* - *---------------------------------------------------------------------- - * - * SerialCheckProc -- - * - * This procedure is called by Tcl_DoOneEvent to check the serial - * event source for events. - * - * Results: - * None. - * - * Side effects: - * May queue an event. - * - *---------------------------------------------------------------------- - */ - -static void -SerialCheckProc( - ClientData data, /* Not used. */ - int flags) /* Event flags as passed to Tcl_DoOneEvent. */ -{ - SerialInfo *infoPtr; - SerialEvent *evPtr; - int needEvent; - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - COMSTAT cStat; - - if (!(flags & TCL_FILE_EVENTS)) { - return; - } - - /* - * Queue events for any ready serials that don't already have events - * queued. - */ - - for (infoPtr = tsdPtr->firstSerialPtr; infoPtr != NULL; - infoPtr = infoPtr->nextPtr) { - if (infoPtr->flags & SERIAL_PENDING) { - continue; - } - - needEvent = 0; - - /* - * If any READABLE or WRITABLE watch mask is set - * call ClearCommError to poll cbInQue,cbOutQue - * Window errors are ignored here - */ - - if( infoPtr->watchMask & (TCL_WRITABLE | TCL_READABLE) ) { - if( ClearCommError( infoPtr->handle, &infoPtr->error, &cStat ) ) { - /* - * Look for empty output buffer. If empty, poll. - */ - - if( infoPtr->watchMask & TCL_WRITABLE ) { - /* - * force fileevent after serial write error - */ - if (((infoPtr->flags & SERIAL_WRITE) != 0) && - ((cStat.cbOutQue == 0) || - (infoPtr->error & SERIAL_WRITE_ERRORS))) { - /* - * allow only one fileevent after each callback - */ - - infoPtr->flags &= ~SERIAL_WRITE; - infoPtr->writable = 1; - needEvent = 1; - } - } - - /* - * Look for characters already pending in windows queue. - * If they are, poll. - */ - - if( infoPtr->watchMask & TCL_READABLE ) { - /* - * force fileevent after serial read error - */ - if( (cStat.cbInQue > 0) || - (infoPtr->error & SERIAL_READ_ERRORS) ) { - infoPtr->readable = 1; - needEvent = 1; - } - } - } - } - - /* - * Queue an event if the serial is signaled for reading or writing. - */ - - if (needEvent) { - infoPtr->flags |= SERIAL_PENDING; - evPtr = (SerialEvent *) ckalloc(sizeof(SerialEvent)); - evPtr->header.proc = SerialEventProc; - evPtr->infoPtr = infoPtr; - Tcl_QueueEvent((Tcl_Event *) evPtr, TCL_QUEUE_TAIL); - } - } -} - -/* - *---------------------------------------------------------------------- - * - * SerialBlockProc -- - * - * Set blocking or non-blocking mode on channel. - * - * Results: - * 0 if successful, errno when failed. - * - * Side effects: - * Sets the device into blocking or non-blocking mode. - * - *---------------------------------------------------------------------- - */ - -static int -SerialBlockProc( - ClientData instanceData, /* Instance data for channel. */ - int mode) /* TCL_MODE_BLOCKING or - * TCL_MODE_NONBLOCKING. */ -{ - COMMTIMEOUTS *timeout; - int errorCode = 0; - - SerialInfo *infoPtr = (SerialInfo *) instanceData; - - /* - * Serial IO on Windows can not be switched between blocking & nonblocking, - * hence we have to emulate the behavior. This is done in the input - * function by checking against a bit in the state. We set or unset the - * bit here to cause the input function to emulate the correct behavior. - */ - - if (mode == TCL_MODE_NONBLOCKING) { - infoPtr->flags |= SERIAL_ASYNC; - timeout = &timeout_async; - } else { - infoPtr->flags &= ~(SERIAL_ASYNC); - timeout = &timeout_sync; - } - if (SetCommTimeouts(infoPtr->handle, timeout) == FALSE) { - TclWinConvertError(GetLastError()); - errorCode = errno; - } - return errorCode; -} - -/* - *---------------------------------------------------------------------- - * - * SerialCloseProc -- - * - * Closes a serial based IO channel. - * - * Results: - * 0 on success, errno otherwise. - * - * Side effects: - * Closes the physical channel. - * - *---------------------------------------------------------------------- - */ - -static int -SerialCloseProc( - ClientData instanceData, /* Pointer to SerialInfo structure. */ - Tcl_Interp *interp) /* For error reporting. */ -{ - SerialInfo *serialPtr = (SerialInfo *) instanceData; - int errorCode, result = 0; - SerialInfo *infoPtr, **nextPtrPtr; - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - - errorCode = 0; - serialPtr->validMask &= ~TCL_READABLE; - serialPtr->validMask &= ~TCL_WRITABLE; - - /* - * Don't close the Win32 handle if the handle is a standard channel - * during the exit process. Otherwise, one thread may kill the stdio - * of another. - */ - - if (!TclInExit() - || ((GetStdHandle(STD_INPUT_HANDLE) != serialPtr->handle) - && (GetStdHandle(STD_OUTPUT_HANDLE) != serialPtr->handle) - && (GetStdHandle(STD_ERROR_HANDLE) != serialPtr->handle))) { - if (CloseHandle(serialPtr->handle) == FALSE) { - TclWinConvertError(GetLastError()); - errorCode = errno; - } - } - - serialPtr->watchMask &= serialPtr->validMask; - - /* - * Remove the file from the list of watched files. - */ - - for (nextPtrPtr = &(tsdPtr->firstSerialPtr), infoPtr = *nextPtrPtr; - infoPtr != NULL; - nextPtrPtr = &infoPtr->nextPtr, infoPtr = *nextPtrPtr) { - if (infoPtr == (SerialInfo *)serialPtr) { - *nextPtrPtr = infoPtr->nextPtr; - break; - } - } - - /* - * Wrap the error file into a channel and give it to the cleanup - * routine. - */ - - ckfree((char*) serialPtr); - - if (errorCode == 0) { - return result; - } - return errorCode; -} - -/* - *---------------------------------------------------------------------- - * - * SerialInputProc -- - * - * Reads input from the IO channel into the buffer given. Returns - * count of how many bytes were actually read, and an error indication. - * - * Results: - * A count of how many bytes were read is returned and an error - * indication is returned in an output argument. - * - * Side effects: - * Reads input from the actual channel. - * - *---------------------------------------------------------------------- - */ -static int -SerialInputProc( - ClientData instanceData, /* Serial state. */ - char *buf, /* Where to store data read. */ - int bufSize, /* How much space is available - * in the buffer? */ - int *errorCode) /* Where to store error code. */ -{ - SerialInfo *infoPtr = (SerialInfo *) instanceData; - DWORD bytesRead = 0; - DWORD err; - COMSTAT cStat; - - *errorCode = 0; - - /* - * Check if there is a CommError pending from SerialCheckProc - */ - if( infoPtr->error & SERIAL_READ_ERRORS ){ - goto commError; - } - - /* - * Look for characters already pending in windows queue. - * This is the mainly restored good old code from Tcl8.0 - */ - - if( ClearCommError( infoPtr->handle, &infoPtr->error, &cStat ) ) { - /* - * Check for errors here, but not in the evSetup/Check procedures - */ - - if( infoPtr->error & SERIAL_READ_ERRORS ) { - goto commError; - } - if( infoPtr->flags & SERIAL_ASYNC ) { - /* - * NON_BLOCKING mode: - * Avoid blocking by reading more bytes than available - * in input buffer - */ - - if( cStat.cbInQue > 0 ) { - if( (DWORD) bufSize > cStat.cbInQue ) { - bufSize = cStat.cbInQue; - } - } else { - errno = *errorCode = EAGAIN; - return -1; - } - } else { - /* - * BLOCKING mode: - * Tcl trys to read a full buffer of 4 kBytes here - */ - - if( cStat.cbInQue > 0 ) { - if( (DWORD) bufSize > cStat.cbInQue ) { - bufSize = cStat.cbInQue; - } - } else { - bufSize = 1; - } - } - } - - if( bufSize == 0 ) { - return bytesRead = 0; - } - - if (ReadFile(infoPtr->handle, (LPVOID) buf, (DWORD) bufSize, &bytesRead, - NULL) == FALSE) { - err = GetLastError(); - if (err != ERROR_IO_PENDING) { - goto error; - } - } - return bytesRead; - - error: - TclWinConvertError(GetLastError()); - *errorCode = errno; - return -1; - - commError: - infoPtr->lastError = infoPtr->error; /* save last error code */ - infoPtr->error = 0; /* reset error code */ - *errorCode = EIO; /* to return read-error only once */ - return -1; -} - -/* - *---------------------------------------------------------------------- - * - * SerialOutputProc -- - * - * Writes the given output on the IO channel. Returns count of how - * many characters were actually written, and an error indication. - * - * Results: - * A count of how many characters were written is returned and an - * error indication is returned in an output argument. - * - * Side effects: - * Writes output on the actual channel. - * - *---------------------------------------------------------------------- - */ - -static int -SerialOutputProc( - ClientData instanceData, /* Serial state. */ - char *buf, /* The data buffer. */ - int toWrite, /* How many bytes to write? */ - int *errorCode) /* Where to store error code. */ -{ - SerialInfo *infoPtr = (SerialInfo *) instanceData; - DWORD bytesWritten, err; - - *errorCode = 0; - - /* - * Check if there is a CommError pending from SerialCheckProc - */ - if( infoPtr->error & SERIAL_WRITE_ERRORS ){ - infoPtr->lastError = infoPtr->error; /* save last error code */ - infoPtr->error = 0; /* reset error code */ - *errorCode = EIO; /* to return read-error only once */ - return -1; - } - - /* - * Check for a background error on the last write. - * Allow one write-fileevent after each callback - */ - - if( toWrite ) { - infoPtr->flags |= SERIAL_WRITE; - } - - if (WriteFile(infoPtr->handle, (LPVOID) buf, (DWORD) toWrite, - &bytesWritten, NULL) == FALSE) { - err = GetLastError(); - if (err != ERROR_IO_PENDING) { - TclWinConvertError(GetLastError()); - goto error; - } - } - - return bytesWritten; - -error: - *errorCode = errno; - return -1; - -} - -/* - *---------------------------------------------------------------------- - * - * SerialEventProc -- - * - * This function is invoked by Tcl_ServiceEvent when a file event - * reaches the front of the event queue. This procedure invokes - * Tcl_NotifyChannel on the serial. - * - * Results: - * Returns 1 if the event was handled, meaning it should be removed - * from the queue. Returns 0 if the event was not handled, meaning - * it should stay on the queue. The only time the event isn't - * handled is if the TCL_FILE_EVENTS flag bit isn't set. - * - * Side effects: - * Whatever the notifier callback does. - * - *---------------------------------------------------------------------- - */ - -static int -SerialEventProc( - Tcl_Event *evPtr, /* Event to service. */ - int flags) /* Flags that indicate what events to - * handle, such as TCL_FILE_EVENTS. */ -{ - SerialEvent *serialEvPtr = (SerialEvent *)evPtr; - SerialInfo *infoPtr; - int mask; - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - - if (!(flags & TCL_FILE_EVENTS)) { - return 0; - } - - /* - * Search through the list of watched serials for the one whose handle - * matches the event. We do this rather than simply dereferencing - * the handle in the event so that serials can be deleted while the - * event is in the queue. - */ - - for (infoPtr = tsdPtr->firstSerialPtr; infoPtr != NULL; - infoPtr = infoPtr->nextPtr) { - if (serialEvPtr->infoPtr == infoPtr) { - infoPtr->flags &= ~(SERIAL_PENDING); - break; - } - } - - /* - * Remove stale events. - */ - - if (!infoPtr) { - return 1; - } - - /* - * Check to see if the serial is readable. Note - * that we can't tell if a serial is writable, so we always report it - * as being writable unless we have detected EOF. - */ - - mask = 0; - if( infoPtr->watchMask & TCL_WRITABLE ) { - if( infoPtr->writable ) { - mask |= TCL_WRITABLE; - infoPtr->writable = 0; - } - } - - if( infoPtr->watchMask & TCL_READABLE ) { - if( infoPtr->readable ) { - mask |= TCL_READABLE; - infoPtr->readable = 0; - } - } - - /* - * Inform the channel of the events. - */ - - Tcl_NotifyChannel(infoPtr->channel, infoPtr->watchMask & mask); - return 1; -} - -/* - *---------------------------------------------------------------------- - * - * SerialWatchProc -- - * - * Called by the notifier to set up to watch for events on this - * channel. - * - * Results: - * None. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static void -SerialWatchProc( - ClientData instanceData, /* Serial state. */ - int mask) /* What events to watch for, OR-ed - * combination of TCL_READABLE, - * TCL_WRITABLE and TCL_EXCEPTION. */ -{ - SerialInfo **nextPtrPtr, *ptr; - SerialInfo *infoPtr = (SerialInfo *) instanceData; - int oldMask = infoPtr->watchMask; - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - - /* - * Since the file is always ready for events, we set the block time - * so we will poll. - */ - - infoPtr->watchMask = mask & infoPtr->validMask; - if (infoPtr->watchMask) { - if (!oldMask) { - infoPtr->nextPtr = tsdPtr->firstSerialPtr; - tsdPtr->firstSerialPtr = infoPtr; - } - SerialBlockTime(infoPtr->blockTime); - } else { - if (oldMask) { - /* - * Remove the serial port from the list of watched serial ports. - */ - - for (nextPtrPtr = &(tsdPtr->firstSerialPtr), ptr = *nextPtrPtr; - ptr != NULL; - nextPtrPtr = &ptr->nextPtr, ptr = *nextPtrPtr) { - if (infoPtr == ptr) { - *nextPtrPtr = ptr->nextPtr; - break; - } - } - } - } -} - -/* - *---------------------------------------------------------------------- - * - * SerialGetHandleProc -- - * - * Called from Tcl_GetChannelHandle to retrieve OS handles from - * inside a command serial port based channel. - * - * Results: - * Returns TCL_OK with the fd in handlePtr, or TCL_ERROR if - * there is no handle for the specified direction. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -SerialGetHandleProc( - ClientData instanceData, /* The serial state. */ - int direction, /* TCL_READABLE or TCL_WRITABLE */ - ClientData *handlePtr) /* Where to store the handle. */ -{ - SerialInfo *infoPtr = (SerialInfo *) instanceData; - - *handlePtr = (ClientData) infoPtr->handle; - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclWinOpenSerialChannel -- - * - * Constructs a Serial port channel for the specified standard OS handle. - * This is a helper function to break up the construction of - * channels into File, Console, or Serial. - * - * Results: - * Returns the new channel, or NULL. - * - * Side effects: - * May open the channel - * - *---------------------------------------------------------------------- - */ - -Tcl_Channel -TclWinOpenSerialChannel(handle, channelName, permissions) - HANDLE handle; - char *channelName; - int permissions; -{ - SerialInfo *infoPtr; - ThreadSpecificData *tsdPtr; - - tsdPtr = SerialInit(); - - SetupComm(handle, 4096, 4096); - PurgeComm(handle, PURGE_TXABORT | PURGE_RXABORT | PURGE_TXCLEAR - | PURGE_RXCLEAR); - - /* - * default is blocking - */ - - SetCommTimeouts(handle, &timeout_sync); - - infoPtr = (SerialInfo *) ckalloc((unsigned) sizeof(SerialInfo)); - memset(infoPtr, 0, sizeof(SerialInfo)); - - infoPtr->validMask = permissions; - infoPtr->handle = handle; - - /* - * Use the pointer to keep the channel names unique, in case - * the handles are shared between multiple channels (stdin/stdout). - */ - - wsprintfA(channelName, "file%lx", (int) infoPtr); - - infoPtr->channel = Tcl_CreateChannel(&serialChannelType, channelName, - (ClientData) infoPtr, permissions); - - - infoPtr->readable = infoPtr->writable = 0; - infoPtr->blockTime = SERIAL_DEFAULT_BLOCKTIME; - infoPtr->lastError = infoPtr->error = 0; - - /* - * Files have default translation of AUTO and ^Z eof char, which - * means that a ^Z will be accepted as EOF when reading. - */ - - Tcl_SetChannelOption(NULL, infoPtr->channel, "-translation", "auto"); - Tcl_SetChannelOption(NULL, infoPtr->channel, "-eofchar", "\032 {}"); - - return infoPtr->channel; -} - -/* - *---------------------------------------------------------------------- - * - * SerialErrorStr -- - * - * Converts a Win32 serial error code to a list of readable errors - * - *---------------------------------------------------------------------- - */ -static void -SerialErrorStr(error, dsPtr) - DWORD error; /* Win32 serial error code */ - Tcl_DString *dsPtr; /* Where to store string */ -{ - if( (error & CE_RXOVER) != 0) { - Tcl_DStringAppendElement(dsPtr, "RXOVER"); - } - if( (error & CE_OVERRUN) != 0) { - Tcl_DStringAppendElement(dsPtr, "OVERRUN"); - } - if( (error & CE_RXPARITY) != 0) { - Tcl_DStringAppendElement(dsPtr, "RXPARITY"); - } - if( (error & CE_FRAME) != 0) { - Tcl_DStringAppendElement(dsPtr, "FRAME"); - } - if( (error & CE_BREAK) != 0) { - Tcl_DStringAppendElement(dsPtr, "BREAK"); - } - if( (error & CE_TXFULL) != 0) { - Tcl_DStringAppendElement(dsPtr, "TXFULL"); - } - if( (error & ~(SERIAL_READ_ERRORS | SERIAL_WRITE_ERRORS)) != 0) { - char buf[TCL_INTEGER_SPACE + 1]; - wsprintfA(buf, "%d", error); - Tcl_DStringAppendElement(dsPtr, buf); - } -} - -/* - *---------------------------------------------------------------------- - * - * SerialSetOptionProc -- - * - * Sets an option on a channel. - * - * Results: - * A standard Tcl result. Also sets the interp's result on error if - * interp is not NULL. - * - * Side effects: - * May modify an option on a device. - * - *---------------------------------------------------------------------- - */ - -static int -SerialSetOptionProc(instanceData, interp, optionName, value) - ClientData instanceData; /* File state. */ - Tcl_Interp *interp; /* For error reporting - can be NULL. */ - char *optionName; /* Which option to set? */ - char *value; /* New value for option. */ -{ - SerialInfo *infoPtr; - DCB dcb; - int len; - BOOL result; - Tcl_DString ds; - TCHAR *native; - - infoPtr = (SerialInfo *) instanceData; - - len = strlen(optionName); - if ((len > 1) && (strncmp(optionName, "-mode", len) == 0)) { - if (GetCommState(infoPtr->handle, &dcb)) { - native = Tcl_WinUtfToTChar(value, -1, &ds); - result = (*tclWinProcs->buildCommDCBProc)(native, &dcb); - Tcl_DStringFree(&ds); - - if ((result == FALSE) || - (SetCommState(infoPtr->handle, &dcb) == FALSE)) { - /* - * one should separate the 2 errors... - */ - - if (interp) { - Tcl_AppendResult(interp, - "bad value for -mode: should be ", - "baud,parity,data,stop", NULL); - } - return TCL_ERROR; - } else { - return TCL_OK; - } - } else { - if (interp) { - Tcl_AppendResult(interp, "can't get comm state", NULL); - } - return TCL_ERROR; - } - } else if ((len > 1) && - (strncmp(optionName, "-pollinterval", len) == 0)) { - if ( Tcl_GetInt(interp, value, &(infoPtr->blockTime)) != TCL_OK ) { - return TCL_ERROR; - } - } else { - return Tcl_BadChannelOption(interp, optionName, - "mode pollinterval"); - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * SerialGetOptionProc -- - * - * Gets a mode associated with an IO channel. If the optionName arg - * is non NULL, retrieves the value of that option. If the optionName - * arg is NULL, retrieves a list of alternating option names and - * values for the given channel. - * - * Results: - * A standard Tcl result. Also sets the supplied DString to the - * string value of the option(s) returned. - * - * Side effects: - * The string returned by this function is in static storage and - * may be reused at any time subsequent to the call. - * - *---------------------------------------------------------------------- - */ -static int -SerialGetOptionProc(instanceData, interp, optionName, dsPtr) - ClientData instanceData; /* File state. */ - Tcl_Interp *interp; /* For error reporting - can be NULL. */ - char *optionName; /* Option to get. */ - Tcl_DString *dsPtr; /* Where to store value(s). */ -{ - SerialInfo *infoPtr; - DCB dcb; - int len; - int valid = 0; /* flag if valid option parsed */ - - infoPtr = (SerialInfo *) instanceData; - - if (optionName == NULL) { - len = 0; - } else { - len = strlen(optionName); - } - - /* - * get option -mode - */ - - if (len == 0) { - Tcl_DStringAppendElement(dsPtr, "-mode"); - } - if ((len == 0) || - ((len > 1) && (strncmp(optionName, "-mode", len) == 0))) { - valid = 1; - if (GetCommState(infoPtr->handle, &dcb) == 0) { - /* - * shouldn't we flag an error instead ? - */ - - Tcl_DStringAppendElement(dsPtr, ""); - - } else { - char parity; - char *stop; - char buf[2 * TCL_INTEGER_SPACE + 16]; - - parity = 'n'; - if (dcb.Parity < 4) { - parity = "noems"[dcb.Parity]; - } - - stop = (dcb.StopBits == ONESTOPBIT) ? "1" : - (dcb.StopBits == ONE5STOPBITS) ? "1.5" : "2"; - - wsprintfA(buf, "%d,%c,%d,%s", dcb.BaudRate, parity, - dcb.ByteSize, stop); - Tcl_DStringAppendElement(dsPtr, buf); - } - } - - /* - * get option -pollinterval - */ - - if (len == 0) { - Tcl_DStringAppendElement(dsPtr, "-pollinterval"); - } - if ((len == 0) || - ((len > 1) && (strncmp(optionName, "-pollinterval", len) == 0))) { - char buf[TCL_INTEGER_SPACE + 1]; - - valid = 1; - wsprintfA(buf, "%d", infoPtr->blockTime); - Tcl_DStringAppendElement(dsPtr, buf); - } - - /* - * get option -lasterror - * option is readonly and returned by [fconfigure chan -lasterror] - * but not returned by unnamed [fconfigure chan] - */ - - if ( (len > 1) && (strncmp(optionName, "-lasterror", len) == 0) ) { - valid = 1; - SerialErrorStr(infoPtr->lastError, dsPtr); - } - - if (valid) { - return TCL_OK; - } else { - return Tcl_BadChannelOption(interp, optionName, - "mode pollinterval lasterror"); - } -} diff --git a/win/tclWinSock.c b/win/tclWinSock.c deleted file mode 100644 index 24429f4..0000000 --- a/win/tclWinSock.c +++ /dev/null @@ -1,2456 +0,0 @@ -/* - * tclWinSock.c -- - * - * This file contains Windows-specific socket related code. - * - * Copyright (c) 1995-1997 Sun Microsystems, Inc. - * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclWinSock.c,v 1.18.2.1 2000/07/27 01:39:26 hobbs Exp $ - */ - -#include "tclWinInt.h" - -/* - * The following variable is used to tell whether this module has been - * initialized. - */ - -static int initialized = 0; - -static int hostnameInitialized = 0; -static char hostname[255]; /* This buffer should be big enough for - * hostname plus domain name. */ - -TCL_DECLARE_MUTEX(socketMutex) - -/* - * The following structure contains pointers to all of the WinSock API entry - * points used by Tcl. It is initialized by InitSockets. Since we - * dynamically load Winsock.dll on demand, we must use this function table - * to refer to functions in the socket API. - */ - -static struct { - HINSTANCE hInstance; /* Handle to WinSock library. */ - SOCKET (PASCAL FAR *accept)(SOCKET s, struct sockaddr FAR *addr, - int FAR *addrlen); - int (PASCAL FAR *bind)(SOCKET s, const struct sockaddr FAR *addr, - int namelen); - int (PASCAL FAR *closesocket)(SOCKET s); - int (PASCAL FAR *connect)(SOCKET s, const struct sockaddr FAR *name, - int namelen); - int (PASCAL FAR *ioctlsocket)(SOCKET s, long cmd, u_long FAR *argp); - int (PASCAL FAR *getsockopt)(SOCKET s, int level, int optname, - char FAR * optval, int FAR *optlen); - u_short (PASCAL FAR *htons)(u_short hostshort); - unsigned long (PASCAL FAR *inet_addr)(const char FAR * cp); - char FAR * (PASCAL FAR *inet_ntoa)(struct in_addr in); - int (PASCAL FAR *listen)(SOCKET s, int backlog); - u_short (PASCAL FAR *ntohs)(u_short netshort); - int (PASCAL FAR *recv)(SOCKET s, char FAR * buf, int len, int flags); - int (PASCAL FAR *select)(int nfds, fd_set FAR * readfds, - fd_set FAR * writefds, fd_set FAR * exceptfds, - const struct timeval FAR * tiemout); - int (PASCAL FAR *send)(SOCKET s, const char FAR * buf, int len, int flags); - int (PASCAL FAR *setsockopt)(SOCKET s, int level, int optname, - const char FAR * optval, int optlen); - int (PASCAL FAR *shutdown)(SOCKET s, int how); - SOCKET (PASCAL FAR *socket)(int af, int type, int protocol); - struct hostent FAR * (PASCAL FAR *gethostbyname)(const char FAR * name); - struct hostent FAR * (PASCAL FAR *gethostbyaddr)(const char FAR *addr, - int addrlen, int addrtype); - int (PASCAL FAR *gethostname)(char FAR * name, int namelen); - int (PASCAL FAR *getpeername)(SOCKET sock, struct sockaddr FAR *name, - int FAR *namelen); - struct servent FAR * (PASCAL FAR *getservbyname)(const char FAR * name, - const char FAR * proto); - int (PASCAL FAR *getsockname)(SOCKET sock, struct sockaddr FAR *name, - int FAR *namelen); - int (PASCAL FAR *WSAStartup)(WORD wVersionRequired, LPWSADATA lpWSAData); - int (PASCAL FAR *WSACleanup)(void); - int (PASCAL FAR *WSAGetLastError)(void); - int (PASCAL FAR *WSAAsyncSelect)(SOCKET s, HWND hWnd, u_int wMsg, - long lEvent); -} winSock; - -/* - * The following defines declare the messages used on socket windows. - */ - -#define SOCKET_MESSAGE WM_USER+1 -#define SOCKET_SELECT WM_USER+2 -#define SOCKET_TERMINATE WM_USER+3 -#define SELECT TRUE -#define UNSELECT FALSE - -/* - * The following structure is used to store the data associated with - * each socket. - */ - -typedef struct SocketInfo { - Tcl_Channel channel; /* Channel associated with this socket. */ - SOCKET socket; /* Windows SOCKET handle. */ - int flags; /* Bit field comprised of the flags - * described below. */ - int watchEvents; /* OR'ed combination of FD_READ, FD_WRITE, - * FD_CLOSE, FD_ACCEPT and FD_CONNECT that - * indicate which events are interesting. */ - int readyEvents; /* OR'ed combination of FD_READ, FD_WRITE, - * FD_CLOSE, FD_ACCEPT and FD_CONNECT that - * indicate which events have occurred. */ - int selectEvents; /* OR'ed combination of FD_READ, FD_WRITE, - * FD_CLOSE, FD_ACCEPT and FD_CONNECT that - * indicate which events are currently - * being selected. */ - int acceptEventCount; /* Count of the current number of FD_ACCEPTs - * that have arrived and not processed. */ - Tcl_TcpAcceptProc *acceptProc; /* Proc to call on accept. */ - ClientData acceptProcData; /* The data for the accept proc. */ - int lastError; /* Error code from last message. */ - struct SocketInfo *nextPtr; /* The next socket on the global socket - * list. */ -} SocketInfo; - -/* - * The following structure is what is added to the Tcl event queue when - * a socket event occurs. - */ - -typedef struct SocketEvent { - Tcl_Event header; /* Information that is standard for - * all events. */ - SOCKET socket; /* Socket descriptor that is ready. Used - * to find the SocketInfo structure for - * the file (can't point directly to the - * SocketInfo structure because it could - * go away while the event is queued). */ -} SocketEvent; - -/* - * This defines the minimum buffersize maintained by the kernel. - */ - -#define TCP_BUFFER_SIZE 4096 - -/* - * The following macros may be used to set the flags field of - * a SocketInfo structure. - */ - -#define SOCKET_ASYNC (1<<0) /* The socket is in blocking mode. */ -#define SOCKET_EOF (1<<1) /* A zero read happened on - * the socket. */ -#define SOCKET_ASYNC_CONNECT (1<<2) /* This socket uses async connect. */ -#define SOCKET_PENDING (1<<3) /* A message has been sent - * for this socket */ - -typedef struct ThreadSpecificData { - /* - * Every open socket has an entry on the following list. - */ - - HWND hwnd; /* Handle to window for socket messages. */ - HANDLE socketThread; /* Thread handling the window */ - Tcl_ThreadId threadId; /* Parent thread. */ - HANDLE readyEvent; /* Event indicating that a socket event is ready. - * Also used to indicate that the socketThread has - * been initialized and has started. */ - HANDLE socketListLock; /* Win32 Event to lock the socketList */ - SocketInfo *socketList; -} ThreadSpecificData; - -static Tcl_ThreadDataKey dataKey; -static WNDCLASSA windowClass; - -/* - * Static functions defined in this file. - */ - -static SocketInfo * CreateSocket _ANSI_ARGS_((Tcl_Interp *interp, - int port, char *host, int server, char *myaddr, - int myport, int async)); -static int CreateSocketAddress _ANSI_ARGS_( - (struct sockaddr_in *sockaddrPtr, - char *host, int port)); -static void InitSockets _ANSI_ARGS_((void)); -static SocketInfo * NewSocketInfo _ANSI_ARGS_((SOCKET socket)); -static void SocketCheckProc _ANSI_ARGS_((ClientData clientData, - int flags)); -static int SocketEventProc _ANSI_ARGS_((Tcl_Event *evPtr, - int flags)); -static void SocketExitHandler _ANSI_ARGS_((ClientData clientData)); -static LRESULT CALLBACK SocketProc _ANSI_ARGS_((HWND hwnd, UINT message, - WPARAM wParam, LPARAM lParam)); -static void SocketSetupProc _ANSI_ARGS_((ClientData clientData, - int flags)); -static void SocketThreadExitHandler _ANSI_ARGS_((ClientData clientData)); -static int SocketsEnabled _ANSI_ARGS_((void)); -static void TcpAccept _ANSI_ARGS_((SocketInfo *infoPtr)); -static int TcpBlockProc _ANSI_ARGS_((ClientData instanceData, - int mode)); -static int TcpCloseProc _ANSI_ARGS_((ClientData instanceData, - Tcl_Interp *interp)); -static int TcpGetOptionProc _ANSI_ARGS_((ClientData instanceData, - Tcl_Interp *interp, char *optionName, - Tcl_DString *optionValue)); -static int TcpInputProc _ANSI_ARGS_((ClientData instanceData, - char *buf, int toRead, int *errorCode)); -static int TcpOutputProc _ANSI_ARGS_((ClientData instanceData, - char *buf, int toWrite, int *errorCode)); -static void TcpWatchProc _ANSI_ARGS_((ClientData instanceData, - int mask)); -static int TcpGetHandleProc _ANSI_ARGS_((ClientData instanceData, - int direction, ClientData *handlePtr)); -static int WaitForSocketEvent _ANSI_ARGS_((SocketInfo *infoPtr, - int events, int *errorCodePtr)); -static DWORD WINAPI SocketThread _ANSI_ARGS_((LPVOID arg)); - -/* - * This structure describes the channel type structure for TCP socket - * based IO. - */ - -static Tcl_ChannelType tcpChannelType = { - "tcp", /* Type name. */ - TCL_CHANNEL_VERSION_2, /* v2 channel */ - TcpCloseProc, /* Close proc. */ - TcpInputProc, /* Input proc. */ - TcpOutputProc, /* Output proc. */ - NULL, /* Seek proc. */ - NULL, /* Set option proc. */ - TcpGetOptionProc, /* Get option proc. */ - TcpWatchProc, /* Set up notifier to watch this channel. */ - TcpGetHandleProc, /* Get an OS handle from channel. */ - NULL, /* close2proc. */ - TcpBlockProc, /* Set blocking/non-blocking mode. */ - NULL, /* flush proc. */ - NULL, /* handler proc. */ -}; - -/* - * Define version of Winsock required by Tcl. - */ - -#define WSA_VERSION_REQD MAKEWORD(1,1) - -/* - *---------------------------------------------------------------------- - * - * InitSockets -- - * - * Initialize the socket module. Attempts to load the wsock32.dll - * library and set up the winSock function table. If successful, - * registers the event window for the socket notifier code. - * - * Assumes Mutex is held. - * - * Results: - * None. - * - * Side effects: - * Dynamically loads wsock32.dll, and registers a new window - * class and creates a window for use in asynchronous socket - * notification. - * - *---------------------------------------------------------------------- - */ - -static void -InitSockets() -{ - DWORD id; - WSADATA wsaData; - ThreadSpecificData *tsdPtr = - (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey); - - if (! initialized) { - initialized = 1; - Tcl_CreateExitHandler(SocketExitHandler, (ClientData) NULL); - - winSock.hInstance = LoadLibraryA("wsock32.dll"); - - /* - * Initialize the function table. - */ - - if (!SocketsEnabled()) { - return; - } - - winSock.accept = (SOCKET (PASCAL FAR *)(SOCKET s, - struct sockaddr FAR *addr, int FAR *addrlen)) - GetProcAddress(winSock.hInstance, "accept"); - winSock.bind = (int (PASCAL FAR *)(SOCKET s, - const struct sockaddr FAR *addr, int namelen)) - GetProcAddress(winSock.hInstance, "bind"); - winSock.closesocket = (int (PASCAL FAR *)(SOCKET s)) - GetProcAddress(winSock.hInstance, "closesocket"); - winSock.connect = (int (PASCAL FAR *)(SOCKET s, - const struct sockaddr FAR *name, int namelen)) - GetProcAddress(winSock.hInstance, "connect"); - winSock.ioctlsocket = (int (PASCAL FAR *)(SOCKET s, long cmd, - u_long FAR *argp)) - GetProcAddress(winSock.hInstance, "ioctlsocket"); - winSock.getsockopt = (int (PASCAL FAR *)(SOCKET s, - int level, int optname, char FAR * optval, int FAR *optlen)) - GetProcAddress(winSock.hInstance, "getsockopt"); - winSock.htons = (u_short (PASCAL FAR *)(u_short hostshort)) - GetProcAddress(winSock.hInstance, "htons"); - winSock.inet_addr = (unsigned long (PASCAL FAR *)(const char FAR *cp)) - GetProcAddress(winSock.hInstance, "inet_addr"); - winSock.inet_ntoa = (char FAR * (PASCAL FAR *)(struct in_addr in)) - GetProcAddress(winSock.hInstance, "inet_ntoa"); - winSock.listen = (int (PASCAL FAR *)(SOCKET s, int backlog)) - GetProcAddress(winSock.hInstance, "listen"); - winSock.ntohs = (u_short (PASCAL FAR *)(u_short netshort)) - GetProcAddress(winSock.hInstance, "ntohs"); - winSock.recv = (int (PASCAL FAR *)(SOCKET s, char FAR * buf, - int len, int flags)) GetProcAddress(winSock.hInstance, "recv"); - winSock.select = (int (PASCAL FAR *)(int nfds, fd_set FAR * readfds, - fd_set FAR * writefds, fd_set FAR * exceptfds, - const struct timeval FAR * tiemout)) - GetProcAddress(winSock.hInstance, "select"); - winSock.send = (int (PASCAL FAR *)(SOCKET s, const char FAR * buf, - int len, int flags)) GetProcAddress(winSock.hInstance, "send"); - winSock.setsockopt = (int (PASCAL FAR *)(SOCKET s, int level, - int optname, const char FAR * optval, int optlen)) - GetProcAddress(winSock.hInstance, "setsockopt"); - winSock.shutdown = (int (PASCAL FAR *)(SOCKET s, int how)) - GetProcAddress(winSock.hInstance, "shutdown"); - winSock.socket = (SOCKET (PASCAL FAR *)(int af, int type, - int protocol)) GetProcAddress(winSock.hInstance, "socket"); - winSock.gethostbyaddr = (struct hostent FAR * (PASCAL FAR *) - (const char FAR *addr, int addrlen, int addrtype)) - GetProcAddress(winSock.hInstance, "gethostbyaddr"); - winSock.gethostbyname = (struct hostent FAR * (PASCAL FAR *) - (const char FAR *name)) - GetProcAddress(winSock.hInstance, "gethostbyname"); - winSock.gethostname = (int (PASCAL FAR *)(char FAR * name, - int namelen)) GetProcAddress(winSock.hInstance, "gethostname"); - winSock.getpeername = (int (PASCAL FAR *)(SOCKET sock, - struct sockaddr FAR *name, int FAR *namelen)) - GetProcAddress(winSock.hInstance, "getpeername"); - winSock.getservbyname = (struct servent FAR * (PASCAL FAR *) - (const char FAR * name, const char FAR * proto)) - GetProcAddress(winSock.hInstance, "getservbyname"); - winSock.getsockname = (int (PASCAL FAR *)(SOCKET sock, - struct sockaddr FAR *name, int FAR *namelen)) - GetProcAddress(winSock.hInstance, "getsockname"); - winSock.WSAStartup = (int (PASCAL FAR *)(WORD wVersionRequired, - LPWSADATA lpWSAData)) GetProcAddress(winSock.hInstance, "WSAStartup"); - winSock.WSACleanup = (int (PASCAL FAR *)(void)) - GetProcAddress(winSock.hInstance, "WSACleanup"); - winSock.WSAGetLastError = (int (PASCAL FAR *)(void)) - GetProcAddress(winSock.hInstance, "WSAGetLastError"); - winSock.WSAAsyncSelect = (int (PASCAL FAR *)(SOCKET s, HWND hWnd, - u_int wMsg, long lEvent)) - GetProcAddress(winSock.hInstance, "WSAAsyncSelect"); - - /* - * Now check that all fields are properly initialized. If not, return - * zero to indicate that we failed to initialize properly. - */ - - if ((winSock.hInstance == NULL) || - (winSock.accept == NULL) || - (winSock.bind == NULL) || - (winSock.closesocket == NULL) || - (winSock.connect == NULL) || - (winSock.ioctlsocket == NULL) || - (winSock.getsockopt == NULL) || - (winSock.htons == NULL) || - (winSock.inet_addr == NULL) || - (winSock.inet_ntoa == NULL) || - (winSock.listen == NULL) || - (winSock.ntohs == NULL) || - (winSock.recv == NULL) || - (winSock.select == NULL) || - (winSock.send == NULL) || - (winSock.setsockopt == NULL) || - (winSock.socket == NULL) || - (winSock.gethostbyname == NULL) || - (winSock.gethostbyaddr == NULL) || - (winSock.gethostname == NULL) || - (winSock.getpeername == NULL) || - (winSock.getservbyname == NULL) || - (winSock.getsockname == NULL) || - (winSock.WSAStartup == NULL) || - (winSock.WSACleanup == NULL) || - (winSock.WSAGetLastError == NULL) || - (winSock.WSAAsyncSelect == NULL)) { - goto unloadLibrary; - } - - /* - * Create the async notification window with a new class. We - * must create a new class to avoid a Windows 95 bug that causes - * us to get the wrong message number for socket events if the - * message window is a subclass of a static control. - */ - - windowClass.style = 0; - windowClass.cbClsExtra = 0; - windowClass.cbWndExtra = 0; - windowClass.hInstance = TclWinGetTclInstance(); - windowClass.hbrBackground = NULL; - windowClass.lpszMenuName = NULL; - windowClass.lpszClassName = "TclSocket"; - windowClass.lpfnWndProc = SocketProc; - windowClass.hIcon = NULL; - windowClass.hCursor = NULL; - - if (!RegisterClassA(&windowClass)) { - TclWinConvertError(GetLastError()); - (*winSock.WSACleanup)(); - goto unloadLibrary; - } - - /* - * Initialize the winsock library and check the version number. - */ - - if ((*winSock.WSAStartup)(WSA_VERSION_REQD, &wsaData) != 0) { - goto unloadLibrary; - } - if (wsaData.wVersion != WSA_VERSION_REQD) { - (*winSock.WSACleanup)(); - goto unloadLibrary; - } - } - - /* - * Check for per-thread initialization. - */ - - if (tsdPtr == NULL) { - tsdPtr = TCL_TSD_INIT(&dataKey); - tsdPtr->socketList = NULL; - tsdPtr->hwnd = NULL; - - tsdPtr->threadId = Tcl_GetCurrentThread(); - - tsdPtr->readyEvent = CreateEvent(NULL, FALSE, FALSE, NULL); - tsdPtr->socketListLock = CreateEvent(NULL, FALSE, TRUE, NULL); - tsdPtr->socketThread = CreateThread(NULL, 8000, SocketThread, - tsdPtr, 0, &id); - SetThreadPriority(tsdPtr->socketThread, THREAD_PRIORITY_HIGHEST); - - if (tsdPtr->socketThread == NULL) { - goto unloadLibrary; - } - - - /* - * Wait for the thread to signal that the window has - * been created and is ready to go. Timeout after twenty - * seconds. - */ - - if (WaitForSingleObject(tsdPtr->readyEvent, 20000) == WAIT_TIMEOUT) { - goto unloadLibrary; - } - - if (tsdPtr->hwnd == NULL) { - goto unloadLibrary; - } - - Tcl_CreateEventSource(SocketSetupProc, SocketCheckProc, NULL); - Tcl_CreateThreadExitHandler(SocketThreadExitHandler, NULL); - } - return; - -unloadLibrary: - if (tsdPtr != NULL) { - if (tsdPtr->hwnd != NULL) { - DestroyWindow(tsdPtr->hwnd); - } - if (tsdPtr->socketThread != NULL) { - TerminateThread(tsdPtr->socketThread, 0); - tsdPtr->socketThread = NULL; - } - CloseHandle(tsdPtr->readyEvent); - CloseHandle(tsdPtr->socketListLock); - } - FreeLibrary(winSock.hInstance); - winSock.hInstance = NULL; - return; -} - -/* - *---------------------------------------------------------------------- - * - * SocketsEnabled -- - * - * Check that the WinSock DLL is loaded and ready. - * - * Results: - * 1 if it is. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -static int -SocketsEnabled() -{ - int enabled; - Tcl_MutexLock(&socketMutex); - enabled = (winSock.hInstance != NULL); - Tcl_MutexUnlock(&socketMutex); - return enabled; -} - - -/* - *---------------------------------------------------------------------- - * - * SocketExitHandler -- - * - * Callback invoked during exit clean up to delete the socket - * communication window and to release the WinSock DLL. - * - * Results: - * None. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -static void -SocketExitHandler(clientData) - ClientData clientData; /* Not used. */ -{ - Tcl_MutexLock(&socketMutex); - if (winSock.hInstance) { - UnregisterClassA("TclSocket", TclWinGetTclInstance()); - (*winSock.WSACleanup)(); - FreeLibrary(winSock.hInstance); - winSock.hInstance = NULL; - } - initialized = 0; - hostnameInitialized = 0; - Tcl_MutexUnlock(&socketMutex); -} - -/* - *---------------------------------------------------------------------- - * - * SocketThreadExitHandler -- - * - * Callback invoked during thread clean up to delete the socket - * event source. - * - * Results: - * None. - * - * Side effects: - * Delete the event source. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -static void -SocketThreadExitHandler(clientData) - ClientData clientData; /* Not used. */ -{ - ThreadSpecificData *tsdPtr = - (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey); - - if (tsdPtr->socketThread != NULL) { - - PostMessage(tsdPtr->hwnd, SOCKET_TERMINATE, 0, 0); - - /* - * Wait for the thread to terminate. This ensures that we are - * completely cleaned up before we leave this function. - */ - - WaitForSingleObject(tsdPtr->socketThread, INFINITE); - CloseHandle(tsdPtr->socketThread); - CloseHandle(tsdPtr->readyEvent); - CloseHandle(tsdPtr->socketListLock); - - } - if (tsdPtr->hwnd != NULL) { - DestroyWindow(tsdPtr->hwnd); - } - - Tcl_DeleteEventSource(SocketSetupProc, SocketCheckProc, NULL); -} - -/* - *---------------------------------------------------------------------- - * - * TclpHasSockets -- - * - * This function determines whether sockets are available on the - * current system and returns an error in interp if they are not. - * Note that interp may be NULL. - * - * Results: - * Returns TCL_OK if the system supports sockets, or TCL_ERROR with - * an error in interp. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -TclpHasSockets(interp) - Tcl_Interp *interp; -{ - Tcl_MutexLock(&socketMutex); - InitSockets(); - Tcl_MutexUnlock(&socketMutex); - - if (SocketsEnabled()) { - return TCL_OK; - } - if (interp != NULL) { - Tcl_AppendResult(interp, "sockets are not available on this system", - NULL); - } - return TCL_ERROR; -} - -/* - *---------------------------------------------------------------------- - * - * SocketSetupProc -- - * - * This procedure is invoked before Tcl_DoOneEvent blocks waiting - * for an event. - * - * Results: - * None. - * - * Side effects: - * Adjusts the block time if needed. - * - *---------------------------------------------------------------------- - */ - -void -SocketSetupProc(data, flags) - ClientData data; /* Not used. */ - int flags; /* Event flags as passed to Tcl_DoOneEvent. */ -{ - SocketInfo *infoPtr; - Tcl_Time blockTime = { 0, 0 }; - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - - if (!(flags & TCL_FILE_EVENTS)) { - return; - } - - /* - * Check to see if there is a ready socket. If so, poll. - */ - - WaitForSingleObject(tsdPtr->socketListLock, INFINITE); - for (infoPtr = tsdPtr->socketList; infoPtr != NULL; - infoPtr = infoPtr->nextPtr) { - if (infoPtr->readyEvents & infoPtr->watchEvents) { - Tcl_SetMaxBlockTime(&blockTime); - break; - } - } - SetEvent(tsdPtr->socketListLock); -} - -/* - *---------------------------------------------------------------------- - * - * SocketCheckProc -- - * - * This procedure is called by Tcl_DoOneEvent to check the socket - * event source for events. - * - * Results: - * None. - * - * Side effects: - * May queue an event. - * - *---------------------------------------------------------------------- - */ - -static void -SocketCheckProc(data, flags) - ClientData data; /* Not used. */ - int flags; /* Event flags as passed to Tcl_DoOneEvent. */ -{ - SocketInfo *infoPtr; - SocketEvent *evPtr; - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - - if (!(flags & TCL_FILE_EVENTS)) { - return; - } - - /* - * Queue events for any ready sockets that don't already have events - * queued (caused by persistent states that won't generate WinSock - * events). - */ - - WaitForSingleObject(tsdPtr->socketListLock, INFINITE); - for (infoPtr = tsdPtr->socketList; infoPtr != NULL; - infoPtr = infoPtr->nextPtr) { - if ((infoPtr->readyEvents & infoPtr->watchEvents) - && !(infoPtr->flags & SOCKET_PENDING)) { - infoPtr->flags |= SOCKET_PENDING; - evPtr = (SocketEvent *) ckalloc(sizeof(SocketEvent)); - evPtr->header.proc = SocketEventProc; - evPtr->socket = infoPtr->socket; - Tcl_QueueEvent((Tcl_Event *) evPtr, TCL_QUEUE_TAIL); - } - } - SetEvent(tsdPtr->socketListLock); -} - -/* - *---------------------------------------------------------------------- - * - * SocketEventProc -- - * - * This procedure is called by Tcl_ServiceEvent when a socket event - * reaches the front of the event queue. This procedure is - * responsible for notifying the generic channel code. - * - * Results: - * Returns 1 if the event was handled, meaning it should be removed - * from the queue. Returns 0 if the event was not handled, meaning - * it should stay on the queue. The only time the event isn't - * handled is if the TCL_FILE_EVENTS flag bit isn't set. - * - * Side effects: - * Whatever the channel callback procedures do. - * - *---------------------------------------------------------------------- - */ - -static int -SocketEventProc(evPtr, flags) - Tcl_Event *evPtr; /* Event to service. */ - int flags; /* Flags that indicate what events to - * handle, such as TCL_FILE_EVENTS. */ -{ - SocketInfo *infoPtr; - SocketEvent *eventPtr = (SocketEvent *) evPtr; - int mask = 0; - int events; - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - - if (!(flags & TCL_FILE_EVENTS)) { - return 0; - } - - /* - * Find the specified socket on the socket list. - */ - - WaitForSingleObject(tsdPtr->socketListLock, INFINITE); - for (infoPtr = tsdPtr->socketList; infoPtr != NULL; - infoPtr = infoPtr->nextPtr) { - if (infoPtr->socket == eventPtr->socket) { - break; - } - } - SetEvent(tsdPtr->socketListLock); - - /* - * Discard events that have gone stale. - */ - - if (!infoPtr) { - return 1; - } - - infoPtr->flags &= ~SOCKET_PENDING; - - /* - * Handle connection requests directly. - */ - - if (infoPtr->readyEvents & FD_ACCEPT) { - TcpAccept(infoPtr); - return 1; - } - - - /* - * Mask off unwanted events and compute the read/write mask so - * we can notify the channel. - */ - - events = infoPtr->readyEvents & infoPtr->watchEvents; - - if (events & FD_CLOSE) { - /* - * If the socket was closed and the channel is still interested - * in read events, then we need to ensure that we keep polling - * for this event until someone does something with the channel. - * Note that we do this before calling Tcl_NotifyChannel so we don't - * have to watch out for the channel being deleted out from under - * us. This may cause a redundant trip through the event loop, but - * it's simpler than trying to do unwind protection. - */ - - Tcl_Time blockTime = { 0, 0 }; - Tcl_SetMaxBlockTime(&blockTime); - mask |= TCL_READABLE; - } else if (events & FD_READ) { - fd_set readFds; - struct timeval timeout; - - /* - * We must check to see if data is really available, since someone - * could have consumed the data in the meantime. Turn off async - * notification so select will work correctly. If the socket is - * still readable, notify the channel driver, otherwise reset the - * async select handler and keep waiting. - */ - - SendMessage(tsdPtr->hwnd, SOCKET_SELECT, - (WPARAM) UNSELECT, (LPARAM) infoPtr); - - FD_ZERO(&readFds); - FD_SET(infoPtr->socket, &readFds); - timeout.tv_usec = 0; - timeout.tv_sec = 0; - - if ((*winSock.select)(0, &readFds, NULL, NULL, &timeout) != 0) { - mask |= TCL_READABLE; - } else { - SendMessage(tsdPtr->hwnd, SOCKET_SELECT, - (WPARAM) SELECT, (LPARAM) infoPtr); - infoPtr->readyEvents &= ~(FD_READ); - } - } - if (events & (FD_WRITE | FD_CONNECT)) { - mask |= TCL_WRITABLE; - } - - if (mask) { - Tcl_NotifyChannel(infoPtr->channel, mask); - } - return 1; -} - -/* - *---------------------------------------------------------------------- - * - * TcpBlockProc -- - * - * Sets a socket into blocking or non-blocking mode. - * - * Results: - * 0 if successful, errno if there was an error. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -TcpBlockProc(instanceData, mode) - ClientData instanceData; /* The socket to block/un-block. */ - int mode; /* TCL_MODE_BLOCKING or - * TCL_MODE_NONBLOCKING. */ -{ - SocketInfo *infoPtr = (SocketInfo *) instanceData; - - if (mode == TCL_MODE_NONBLOCKING) { - infoPtr->flags |= SOCKET_ASYNC; - } else { - infoPtr->flags &= ~(SOCKET_ASYNC); - } - return 0; -} - -/* - *---------------------------------------------------------------------- - * - * TcpCloseProc -- - * - * This procedure is called by the generic IO level to perform - * channel type specific cleanup on a socket based channel - * when the channel is closed. - * - * Results: - * 0 if successful, the value of errno if failed. - * - * Side effects: - * Closes the socket. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -static int -TcpCloseProc(instanceData, interp) - ClientData instanceData; /* The socket to close. */ - Tcl_Interp *interp; /* Unused. */ -{ - SocketInfo *infoPtr = (SocketInfo *) instanceData; - SocketInfo **nextPtrPtr; - int errorCode = 0; - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - - /* - * Check that WinSock is initialized; do not call it if not, to - * prevent system crashes. This can happen at exit time if the exit - * handler for WinSock ran before other exit handlers that want to - * use sockets. - */ - - if (SocketsEnabled()) { - - /* - * Clean up the OS socket handle. The default Windows setting - * for a socket is SO_DONTLINGER, which does a graceful shutdown - * in the background. - */ - - if ((*winSock.closesocket)(infoPtr->socket) == SOCKET_ERROR) { - TclWinConvertWSAError((*winSock.WSAGetLastError)()); - errorCode = Tcl_GetErrno(); - } - } - - /* - * Remove the socket from socketList. - */ - - WaitForSingleObject(tsdPtr->socketListLock, INFINITE); - for (nextPtrPtr = &(tsdPtr->socketList); (*nextPtrPtr) != NULL; - nextPtrPtr = &((*nextPtrPtr)->nextPtr)) { - if ((*nextPtrPtr) == infoPtr) { - (*nextPtrPtr) = infoPtr->nextPtr; - break; - } - } - SetEvent(tsdPtr->socketListLock); - - ckfree((char *) infoPtr); - return errorCode; -} - -/* - *---------------------------------------------------------------------- - * - * NewSocketInfo -- - * - * This function allocates and initializes a new SocketInfo - * structure. - * - * Results: - * Returns a newly allocated SocketInfo. - * - * Side effects: - * Adds the socket to the global socket list. - * - *---------------------------------------------------------------------- - */ - -static SocketInfo * -NewSocketInfo(socket) - SOCKET socket; -{ - SocketInfo *infoPtr; - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - - infoPtr = (SocketInfo *) ckalloc((unsigned) sizeof(SocketInfo)); - infoPtr->socket = socket; - infoPtr->flags = 0; - infoPtr->watchEvents = 0; - infoPtr->readyEvents = 0; - infoPtr->selectEvents = 0; - infoPtr->acceptEventCount = 0; - infoPtr->acceptProc = NULL; - infoPtr->lastError = 0; - - WaitForSingleObject(tsdPtr->socketListLock, INFINITE); - infoPtr->nextPtr = tsdPtr->socketList; - tsdPtr->socketList = infoPtr; - SetEvent(tsdPtr->socketListLock); - - return infoPtr; -} - -/* - *---------------------------------------------------------------------- - * - * CreateSocket -- - * - * This function opens a new socket and initializes the - * SocketInfo structure. - * - * Results: - * Returns a new SocketInfo, or NULL with an error in interp. - * - * Side effects: - * Adds a new socket to the socketList. - * - *---------------------------------------------------------------------- - */ - -static SocketInfo * -CreateSocket(interp, port, host, server, myaddr, myport, async) - Tcl_Interp *interp; /* For error reporting; can be NULL. */ - int port; /* Port number to open. */ - char *host; /* Name of host on which to open port. */ - int server; /* 1 if socket should be a server socket, - * else 0 for a client socket. */ - char *myaddr; /* Optional client-side address */ - int myport; /* Optional client-side port */ - int async; /* If nonzero, connect client socket - * asynchronously. */ -{ - u_long flag = 1; /* Indicates nonblocking mode. */ - int asyncConnect = 0; /* Will be 1 if async connect is - * in progress. */ - struct sockaddr_in sockaddr; /* Socket address */ - struct sockaddr_in mysockaddr; /* Socket address for client */ - SOCKET sock; - SocketInfo *infoPtr; /* The returned value. */ - ThreadSpecificData *tsdPtr = - (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey); - - /* - * Check that WinSock is initialized; do not call it if not, to - * prevent system crashes. This can happen at exit time if the exit - * handler for WinSock ran before other exit handlers that want to - * use sockets. - */ - - if (!SocketsEnabled()) { - return NULL; - } - - if (! CreateSocketAddress(&sockaddr, host, port)) { - goto error; - } - if ((myaddr != NULL || myport != 0) && - ! CreateSocketAddress(&mysockaddr, myaddr, myport)) { - goto error; - } - - sock = (*winSock.socket)(AF_INET, SOCK_STREAM, 0); - if (sock == INVALID_SOCKET) { - goto error; - } - - /* - * Win-NT has a misfeature that sockets are inherited in child - * processes by default. Turn off the inherit bit. - */ - - SetHandleInformation( (HANDLE) sock, HANDLE_FLAG_INHERIT, 0 ); - - /* - * Set kernel space buffering - */ - - TclSockMinimumBuffers(sock, TCP_BUFFER_SIZE); - - if (server) { - /* - * Bind to the specified port. Note that we must not call setsockopt - * with SO_REUSEADDR because Microsoft allows addresses to be reused - * even if they are still in use. - * - * Bind should not be affected by the socket having already been - * set into nonblocking mode. If there is trouble, this is one place - * to look for bugs. - */ - - if ((*winSock.bind)(sock, (struct sockaddr *) &sockaddr, - sizeof(sockaddr)) == SOCKET_ERROR) { - goto error; - } - - /* - * Set the maximum number of pending connect requests to the - * max value allowed on each platform (Win32 and Win32s may be - * different, and there may be differences between TCP/IP stacks). - */ - - if ((*winSock.listen)(sock, SOMAXCONN) == SOCKET_ERROR) { - goto error; - } - - /* - * Add this socket to the global list of sockets. - */ - - infoPtr = NewSocketInfo(sock); - - /* - * Set up the select mask for connection request events. - */ - - infoPtr->selectEvents = FD_ACCEPT; - infoPtr->watchEvents |= FD_ACCEPT; - - } else { - - /* - * Try to bind to a local port, if specified. - */ - - if (myaddr != NULL || myport != 0) { - if ((*winSock.bind)(sock, (struct sockaddr *) &mysockaddr, - sizeof(struct sockaddr)) == SOCKET_ERROR) { - goto error; - } - } - - /* - * Set the socket into nonblocking mode if the connect should be - * done in the background. - */ - - if (async) { - if ((*winSock.ioctlsocket)(sock, FIONBIO, &flag) == SOCKET_ERROR) { - goto error; - } - } - - /* - * Attempt to connect to the remote socket. - */ - - if ((*winSock.connect)(sock, (struct sockaddr *) &sockaddr, - sizeof(sockaddr)) == SOCKET_ERROR) { - TclWinConvertWSAError((*winSock.WSAGetLastError)()); - if (Tcl_GetErrno() != EWOULDBLOCK) { - goto error; - } - - /* - * The connection is progressing in the background. - */ - - asyncConnect = 1; - } - - /* - * Add this socket to the global list of sockets. - */ - - infoPtr = NewSocketInfo(sock); - - /* - * Set up the select mask for read/write events. If the connect - * attempt has not completed, include connect events. - */ - - infoPtr->selectEvents = FD_READ | FD_WRITE | FD_CLOSE; - if (asyncConnect) { - infoPtr->flags |= SOCKET_ASYNC_CONNECT; - infoPtr->selectEvents |= FD_CONNECT; - } - } - - /* - * Register for interest in events in the select mask. Note that this - * automatically places the socket into non-blocking mode. - */ - - (*winSock.ioctlsocket)(sock, FIONBIO, &flag); - SendMessage(tsdPtr->hwnd, SOCKET_SELECT, - (WPARAM) SELECT, (LPARAM) infoPtr); - - return infoPtr; - -error: - TclWinConvertWSAError((*winSock.WSAGetLastError)()); - if (interp != NULL) { - Tcl_AppendResult(interp, "couldn't open socket: ", - Tcl_PosixError(interp), (char *) NULL); - } - if (sock != INVALID_SOCKET) { - (*winSock.closesocket)(sock); - } - return NULL; -} - -/* - *---------------------------------------------------------------------- - * - * CreateSocketAddress -- - * - * This function initializes a sockaddr structure for a host and port. - * - * Results: - * 1 if the host was valid, 0 if the host could not be converted to - * an IP address. - * - * Side effects: - * Fills in the *sockaddrPtr structure. - * - *---------------------------------------------------------------------- - */ - -static int -CreateSocketAddress(sockaddrPtr, host, port) - struct sockaddr_in *sockaddrPtr; /* Socket address */ - char *host; /* Host. NULL implies INADDR_ANY */ - int port; /* Port number */ -{ - struct hostent *hostent; /* Host database entry */ - struct in_addr addr; /* For 64/32 bit madness */ - - /* - * Check that WinSock is initialized; do not call it if not, to - * prevent system crashes. This can happen at exit time if the exit - * handler for WinSock ran before other exit handlers that want to - * use sockets. - */ - - if (!SocketsEnabled()) { - Tcl_SetErrno(EFAULT); - return 0; - } - - (void) memset((char *) sockaddrPtr, '\0', sizeof(struct sockaddr_in)); - sockaddrPtr->sin_family = AF_INET; - sockaddrPtr->sin_port = (*winSock.htons)((short) (port & 0xFFFF)); - if (host == NULL) { - addr.s_addr = INADDR_ANY; - } else { - addr.s_addr = (*winSock.inet_addr)(host); - if (addr.s_addr == INADDR_NONE) { - hostent = (*winSock.gethostbyname)(host); - if (hostent != NULL) { - memcpy((char *) &addr, - (char *) hostent->h_addr_list[0], - (size_t) hostent->h_length); - } else { -#ifdef EHOSTUNREACH - Tcl_SetErrno(EHOSTUNREACH); -#else -#ifdef ENXIO - Tcl_SetErrno(ENXIO); -#endif -#endif - return 0; /* Error. */ - } - } - } - - /* - * NOTE: On 64 bit machines the assignment below is rumored to not - * do the right thing. Please report errors related to this if you - * observe incorrect behavior on 64 bit machines such as DEC Alphas. - * Should we modify this code to do an explicit memcpy? - */ - - sockaddrPtr->sin_addr.s_addr = addr.s_addr; - return 1; /* Success. */ -} - -/* - *---------------------------------------------------------------------- - * - * WaitForSocketEvent -- - * - * Waits until one of the specified events occurs on a socket. - * - * Results: - * Returns 1 on success or 0 on failure, with an error code in - * errorCodePtr. - * - * Side effects: - * Processes socket events off the system queue. - * - *---------------------------------------------------------------------- - */ - -static int -WaitForSocketEvent(infoPtr, events, errorCodePtr) - SocketInfo *infoPtr; /* Information about this socket. */ - int events; /* Events to look for. */ - int *errorCodePtr; /* Where to store errors? */ -{ - int result = 1; - int oldMode; - ThreadSpecificData *tsdPtr = - (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey); - - /* - * Be sure to disable event servicing so we are truly modal. - */ - - oldMode = Tcl_SetServiceMode(TCL_SERVICE_NONE); - - /* - * Reset WSAAsyncSelect so we have a fresh set of events pending. - */ - - SendMessage(tsdPtr->hwnd, SOCKET_SELECT, - (WPARAM) UNSELECT, (LPARAM) infoPtr); - - SendMessage(tsdPtr->hwnd, SOCKET_SELECT, - (WPARAM) SELECT, (LPARAM) infoPtr); - - while (1) { - - if (infoPtr->lastError) { - *errorCodePtr = infoPtr->lastError; - result = 0; - break; - } else if (infoPtr->readyEvents & events) { - break; - } else if (infoPtr->flags & SOCKET_ASYNC) { - *errorCodePtr = EWOULDBLOCK; - result = 0; - break; - } - - /* - * Wait until something happens. - */ - WaitForSingleObject(tsdPtr->readyEvent, INFINITE); - } - - (void) Tcl_SetServiceMode(oldMode); - return result; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_OpenTcpClient -- - * - * Opens a TCP client socket and creates a channel around it. - * - * Results: - * The channel or NULL if failed. An error message is returned - * in the interpreter on failure. - * - * Side effects: - * Opens a client socket and creates a new channel. - * - *---------------------------------------------------------------------- - */ - -Tcl_Channel -Tcl_OpenTcpClient(interp, port, host, myaddr, myport, async) - Tcl_Interp *interp; /* For error reporting; can be NULL. */ - int port; /* Port number to open. */ - char *host; /* Host on which to open port. */ - char *myaddr; /* Client-side address */ - int myport; /* Client-side port */ - int async; /* If nonzero, should connect - * client socket asynchronously. */ -{ - SocketInfo *infoPtr; - char channelName[16 + TCL_INTEGER_SPACE]; - - if (TclpHasSockets(interp) != TCL_OK) { - return NULL; - } - - /* - * Create a new client socket and wrap it in a channel. - */ - - infoPtr = CreateSocket(interp, port, host, 0, myaddr, myport, async); - if (infoPtr == NULL) { - return NULL; - } - - wsprintfA(channelName, "sock%d", infoPtr->socket); - - infoPtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName, - (ClientData) infoPtr, (TCL_READABLE | TCL_WRITABLE)); - if (Tcl_SetChannelOption(interp, infoPtr->channel, "-translation", - "auto crlf") == TCL_ERROR) { - Tcl_Close((Tcl_Interp *) NULL, infoPtr->channel); - return (Tcl_Channel) NULL; - } - if (Tcl_SetChannelOption(NULL, infoPtr->channel, "-eofchar", "") - == TCL_ERROR) { - Tcl_Close((Tcl_Interp *) NULL, infoPtr->channel); - return (Tcl_Channel) NULL; - } - return infoPtr->channel; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_MakeTcpClientChannel -- - * - * Creates a Tcl_Channel from an existing client TCP socket. - * - * Results: - * The Tcl_Channel wrapped around the preexisting TCP socket. - * - * Side effects: - * None. - * - * NOTE: Code contributed by Mark Diekhans (markd@grizzly.com) - * - *---------------------------------------------------------------------- - */ - -Tcl_Channel -Tcl_MakeTcpClientChannel(sock) - ClientData sock; /* The socket to wrap up into a channel. */ -{ - SocketInfo *infoPtr; - char channelName[16 + TCL_INTEGER_SPACE]; - ThreadSpecificData *tsdPtr; - - if (TclpHasSockets(NULL) != TCL_OK) { - return NULL; - } - - tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey); - - /* - * Set kernel space buffering and non-blocking. - */ - - TclSockMinimumBuffers((SOCKET) sock, TCP_BUFFER_SIZE); - - infoPtr = NewSocketInfo((SOCKET) sock); - - /* - * Start watching for read/write events on the socket. - */ - - infoPtr->selectEvents = FD_READ | FD_CLOSE | FD_WRITE; - SendMessage(tsdPtr->hwnd, SOCKET_SELECT, - (WPARAM) SELECT, (LPARAM) infoPtr); - - wsprintfA(channelName, "sock%d", infoPtr->socket); - infoPtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName, - (ClientData) infoPtr, (TCL_READABLE | TCL_WRITABLE)); - Tcl_SetChannelOption(NULL, infoPtr->channel, "-translation", "auto crlf"); - return infoPtr->channel; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_OpenTcpServer -- - * - * Opens a TCP server socket and creates a channel around it. - * - * Results: - * The channel or NULL if failed. An error message is returned - * in the interpreter on failure. - * - * Side effects: - * Opens a server socket and creates a new channel. - * - *---------------------------------------------------------------------- - */ - -Tcl_Channel -Tcl_OpenTcpServer(interp, port, host, acceptProc, acceptProcData) - Tcl_Interp *interp; /* For error reporting - may be - * NULL. */ - int port; /* Port number to open. */ - char *host; /* Name of local host. */ - Tcl_TcpAcceptProc *acceptProc; /* Callback for accepting connections - * from new clients. */ - ClientData acceptProcData; /* Data for the callback. */ -{ - SocketInfo *infoPtr; - char channelName[16 + TCL_INTEGER_SPACE]; - - if (TclpHasSockets(interp) != TCL_OK) { - return NULL; - } - - /* - * Create a new client socket and wrap it in a channel. - */ - - infoPtr = CreateSocket(interp, port, host, 1, NULL, 0, 0); - if (infoPtr == NULL) { - return NULL; - } - - infoPtr->acceptProc = acceptProc; - infoPtr->acceptProcData = acceptProcData; - - wsprintfA(channelName, "sock%d", infoPtr->socket); - - infoPtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName, - (ClientData) infoPtr, 0); - if (Tcl_SetChannelOption(interp, infoPtr->channel, "-eofchar", "") - == TCL_ERROR) { - Tcl_Close((Tcl_Interp *) NULL, infoPtr->channel); - return (Tcl_Channel) NULL; - } - - return infoPtr->channel; -} - -/* - *---------------------------------------------------------------------- - * - * TcpAccept -- - * Accept a TCP socket connection. This is called by - * SocketEventProc and it in turns calls the registered accept - * procedure. - * - * Results: - * None. - * - * Side effects: - * Invokes the accept proc which may invoke arbitrary Tcl code. - * - *---------------------------------------------------------------------- - */ - -static void -TcpAccept(infoPtr) - SocketInfo *infoPtr; /* Socket to accept. */ -{ - SOCKET newSocket; - SocketInfo *newInfoPtr; - struct sockaddr_in addr; - int len; - char channelName[16 + TCL_INTEGER_SPACE]; - ThreadSpecificData *tsdPtr = - (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey); - - /* - * Accept the incoming connection request. - */ - - len = sizeof(struct sockaddr_in); - - newSocket = (*winSock.accept)(infoPtr->socket, - (struct sockaddr *)&addr, - &len); - - /* - * Clear the ready mask so we can detect the next connection request. - * Note that connection requests are level triggered, so if there is - * a request already pending, a new event will be generated. - */ - - if (newSocket == INVALID_SOCKET) { - infoPtr->acceptEventCount = 0; - infoPtr->readyEvents &= ~(FD_ACCEPT); - return; - } - - /* - * It is possible that more than one FD_ACCEPT has been sent, so an extra - * count must be kept. Decrement the count, and reset the readyEvent bit - * if the count is no longer > 0. - */ - - infoPtr->acceptEventCount--; - - if (infoPtr->acceptEventCount <= 0) { - infoPtr->readyEvents &= ~(FD_ACCEPT); - } - - /* - * Win-NT has a misfeature that sockets are inherited in child - * processes by default. Turn off the inherit bit. - */ - - SetHandleInformation( (HANDLE) newSocket, HANDLE_FLAG_INHERIT, 0 ); - - /* - * Add this socket to the global list of sockets. - */ - - newInfoPtr = NewSocketInfo(newSocket); - - /* - * Select on read/write events and create the channel. - */ - - newInfoPtr->selectEvents = (FD_READ | FD_WRITE | FD_CLOSE); - SendMessage(tsdPtr->hwnd, SOCKET_SELECT, - (WPARAM) SELECT, (LPARAM) newInfoPtr); - - wsprintfA(channelName, "sock%d", newInfoPtr->socket); - newInfoPtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName, - (ClientData) newInfoPtr, (TCL_READABLE | TCL_WRITABLE)); - if (Tcl_SetChannelOption(NULL, newInfoPtr->channel, "-translation", - "auto crlf") == TCL_ERROR) { - Tcl_Close((Tcl_Interp *) NULL, newInfoPtr->channel); - return; - } - if (Tcl_SetChannelOption(NULL, newInfoPtr->channel, "-eofchar", "") - == TCL_ERROR) { - Tcl_Close((Tcl_Interp *) NULL, newInfoPtr->channel); - return; - } - - /* - * Invoke the accept callback procedure. - */ - - if (infoPtr->acceptProc != NULL) { - (infoPtr->acceptProc) (infoPtr->acceptProcData, - newInfoPtr->channel, - (*winSock.inet_ntoa)(addr.sin_addr), - (*winSock.ntohs)(addr.sin_port)); - } -} - -/* - *---------------------------------------------------------------------- - * - * TcpInputProc -- - * - * This procedure is called by the generic IO level to read data from - * a socket based channel. - * - * Results: - * The number of bytes read or -1 on error. - * - * Side effects: - * Consumes input from the socket. - * - *---------------------------------------------------------------------- - */ - -static int -TcpInputProc(instanceData, buf, toRead, errorCodePtr) - ClientData instanceData; /* The socket state. */ - char *buf; /* Where to store data. */ - int toRead; /* Maximum number of bytes to read. */ - int *errorCodePtr; /* Where to store error codes. */ -{ - SocketInfo *infoPtr = (SocketInfo *) instanceData; - int bytesRead; - int error; - ThreadSpecificData *tsdPtr = - (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey); - - *errorCodePtr = 0; - - /* - * Check that WinSock is initialized; do not call it if not, to - * prevent system crashes. This can happen at exit time if the exit - * handler for WinSock ran before other exit handlers that want to - * use sockets. - */ - - if (!SocketsEnabled()) { - *errorCodePtr = EFAULT; - return -1; - } - - /* - * First check to see if EOF was already detected, to prevent - * calling the socket stack after the first time EOF is detected. - */ - - if (infoPtr->flags & SOCKET_EOF) { - return 0; - } - - /* - * Check to see if the socket is connected before trying to read. - */ - - if ((infoPtr->flags & SOCKET_ASYNC_CONNECT) - && ! WaitForSocketEvent(infoPtr, FD_CONNECT, errorCodePtr)) { - return -1; - } - - /* - * No EOF, and it is connected, so try to read more from the socket. - * Note that we clear the FD_READ bit because read events are level - * triggered so a new event will be generated if there is still data - * available to be read. We have to simulate blocking behavior here - * since we are always using non-blocking sockets. - */ - - while (1) { - SendMessage(tsdPtr->hwnd, SOCKET_SELECT, - (WPARAM) UNSELECT, (LPARAM) infoPtr); - bytesRead = (*winSock.recv)(infoPtr->socket, buf, toRead, 0); - infoPtr->readyEvents &= ~(FD_READ); - - /* - * Check for end-of-file condition or successful read. - */ - - if (bytesRead == 0) { - infoPtr->flags |= SOCKET_EOF; - } - if (bytesRead != SOCKET_ERROR) { - break; - } - - /* - * If an error occurs after the FD_CLOSE has arrived, - * then ignore the error and report an EOF. - */ - - if (infoPtr->readyEvents & FD_CLOSE) { - infoPtr->flags |= SOCKET_EOF; - bytesRead = 0; - break; - } - - /* - * Check for error condition or underflow in non-blocking case. - */ - - error = (*winSock.WSAGetLastError)(); - if ((infoPtr->flags & SOCKET_ASYNC) || (error != WSAEWOULDBLOCK)) { - TclWinConvertWSAError(error); - *errorCodePtr = Tcl_GetErrno(); - bytesRead = -1; - break; - } - - /* - * In the blocking case, wait until the file becomes readable - * or closed and try again. - */ - - if (!WaitForSocketEvent(infoPtr, FD_READ|FD_CLOSE, errorCodePtr)) { - bytesRead = -1; - break; - } - } - - SendMessage(tsdPtr->hwnd, SOCKET_SELECT, - (WPARAM) SELECT, (LPARAM) infoPtr); - - return bytesRead; -} - -/* - *---------------------------------------------------------------------- - * - * TcpOutputProc -- - * - * This procedure is called by the generic IO level to write data - * to a socket based channel. - * - * Results: - * The number of bytes written or -1 on failure. - * - * Side effects: - * Produces output on the socket. - * - *---------------------------------------------------------------------- - */ - -static int -TcpOutputProc(instanceData, buf, toWrite, errorCodePtr) - ClientData instanceData; /* The socket state. */ - char *buf; /* Where to get data. */ - int toWrite; /* Maximum number of bytes to write. */ - int *errorCodePtr; /* Where to store error codes. */ -{ - SocketInfo *infoPtr = (SocketInfo *) instanceData; - int bytesWritten; - int error; - ThreadSpecificData *tsdPtr = - (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey); - - *errorCodePtr = 0; - - /* - * Check that WinSock is initialized; do not call it if not, to - * prevent system crashes. This can happen at exit time if the exit - * handler for WinSock ran before other exit handlers that want to - * use sockets. - */ - - if (!SocketsEnabled()) { - *errorCodePtr = EFAULT; - return -1; - } - - /* - * Check to see if the socket is connected before trying to write. - */ - - if ((infoPtr->flags & SOCKET_ASYNC_CONNECT) - && ! WaitForSocketEvent(infoPtr, FD_CONNECT, errorCodePtr)) { - return -1; - } - - while (1) { - SendMessage(tsdPtr->hwnd, SOCKET_SELECT, - (WPARAM) UNSELECT, (LPARAM) infoPtr); - - bytesWritten = (*winSock.send)(infoPtr->socket, buf, toWrite, 0); - if (bytesWritten != SOCKET_ERROR) { - /* - * Since Windows won't generate a new write event until we hit - * an overflow condition, we need to force the event loop to - * poll until the condition changes. - */ - - if (infoPtr->watchEvents & FD_WRITE) { - Tcl_Time blockTime = { 0, 0 }; - Tcl_SetMaxBlockTime(&blockTime); - } - break; - } - - /* - * Check for error condition or overflow. In the event of overflow, we - * need to clear the FD_WRITE flag so we can detect the next writable - * event. Note that Windows only sends a new writable event after a - * send fails with WSAEWOULDBLOCK. - */ - - error = (*winSock.WSAGetLastError)(); - if (error == WSAEWOULDBLOCK) { - infoPtr->readyEvents &= ~(FD_WRITE); - if (infoPtr->flags & SOCKET_ASYNC) { - *errorCodePtr = EWOULDBLOCK; - bytesWritten = -1; - break; - } - } else { - TclWinConvertWSAError(error); - *errorCodePtr = Tcl_GetErrno(); - bytesWritten = -1; - break; - } - - /* - * In the blocking case, wait until the file becomes writable - * or closed and try again. - */ - - if (!WaitForSocketEvent(infoPtr, FD_WRITE|FD_CLOSE, errorCodePtr)) { - bytesWritten = -1; - break; - } - } - - SendMessage(tsdPtr->hwnd, SOCKET_SELECT, - (WPARAM) SELECT, (LPARAM) infoPtr); - - return bytesWritten; -} - -/* - *---------------------------------------------------------------------- - * - * TcpGetOptionProc -- - * - * Computes an option value for a TCP socket based channel, or a - * list of all options and their values. - * - * Note: This code is based on code contributed by John Haxby. - * - * Results: - * A standard Tcl result. The value of the specified option or a - * list of all options and their values is returned in the - * supplied DString. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -TcpGetOptionProc(instanceData, interp, optionName, dsPtr) - ClientData instanceData; /* Socket state. */ - Tcl_Interp *interp; /* For error reporting - can be NULL */ - char *optionName; /* Name of the option to - * retrieve the value for, or - * NULL to get all options and - * their values. */ - Tcl_DString *dsPtr; /* Where to store the computed - * value; initialized by caller. */ -{ - SocketInfo *infoPtr; - struct sockaddr_in sockname; - struct sockaddr_in peername; - struct hostent *hostEntPtr; - SOCKET sock; - int size = sizeof(struct sockaddr_in); - size_t len = 0; - char buf[TCL_INTEGER_SPACE]; - - /* - * Check that WinSock is initialized; do not call it if not, to - * prevent system crashes. This can happen at exit time if the exit - * handler for WinSock ran before other exit handlers that want to - * use sockets. - */ - - if (!SocketsEnabled()) { - if (interp) { - Tcl_AppendResult(interp, "winsock is not initialized", NULL); - } - return TCL_ERROR; - } - - infoPtr = (SocketInfo *) instanceData; - sock = (int) infoPtr->socket; - if (optionName != (char *) NULL) { - len = strlen(optionName); - } - - if ((len > 1) && (optionName[1] == 'e') && - (strncmp(optionName, "-error", len) == 0)) { - int optlen; - int err, ret; - - optlen = sizeof(int); - ret = TclWinGetSockOpt(sock, SOL_SOCKET, SO_ERROR, - (char *)&err, &optlen); - if (ret == SOCKET_ERROR) { - err = (*winSock.WSAGetLastError)(); - } - if (err) { - TclWinConvertWSAError(err); - Tcl_DStringAppend(dsPtr, Tcl_ErrnoMsg(Tcl_GetErrno()), -1); - } - return TCL_OK; - } - - if ((len == 0) || - ((len > 1) && (optionName[1] == 'p') && - (strncmp(optionName, "-peername", len) == 0))) { - if ((*winSock.getpeername)(sock, (struct sockaddr *) &peername, &size) - == 0) { - if (len == 0) { - Tcl_DStringAppendElement(dsPtr, "-peername"); - Tcl_DStringStartSublist(dsPtr); - } - Tcl_DStringAppendElement(dsPtr, - (*winSock.inet_ntoa)(peername.sin_addr)); - hostEntPtr = (*winSock.gethostbyaddr)( - (char *) &(peername.sin_addr), sizeof(peername.sin_addr), - AF_INET); - if (hostEntPtr != (struct hostent *) NULL) { - Tcl_DStringAppendElement(dsPtr, hostEntPtr->h_name); - } else { - Tcl_DStringAppendElement(dsPtr, - (*winSock.inet_ntoa)(peername.sin_addr)); - } - TclFormatInt(buf, (*winSock.ntohs)(peername.sin_port)); - Tcl_DStringAppendElement(dsPtr, buf); - if (len == 0) { - Tcl_DStringEndSublist(dsPtr); - } else { - return TCL_OK; - } - } else { - /* - * getpeername failed - but if we were asked for all the options - * (len==0), don't flag an error at that point because it could - * be an fconfigure request on a server socket. (which have - * no peer). {copied from unix/tclUnixChan.c} - */ - if (len) { - TclWinConvertWSAError((*winSock.WSAGetLastError)()); - if (interp) { - Tcl_AppendResult(interp, "can't get peername: ", - Tcl_PosixError(interp), - (char *) NULL); - } - return TCL_ERROR; - } - } - } - - if ((len == 0) || - ((len > 1) && (optionName[1] == 's') && - (strncmp(optionName, "-sockname", len) == 0))) { - if ((*winSock.getsockname)(sock, (struct sockaddr *) &sockname, &size) - == 0) { - if (len == 0) { - Tcl_DStringAppendElement(dsPtr, "-sockname"); - Tcl_DStringStartSublist(dsPtr); - } - Tcl_DStringAppendElement(dsPtr, - (*winSock.inet_ntoa)(sockname.sin_addr)); - hostEntPtr = (*winSock.gethostbyaddr)( - (char *) &(sockname.sin_addr), sizeof(peername.sin_addr), - AF_INET); - if (hostEntPtr != (struct hostent *) NULL) { - Tcl_DStringAppendElement(dsPtr, hostEntPtr->h_name); - } else { - Tcl_DStringAppendElement(dsPtr, - (*winSock.inet_ntoa)(sockname.sin_addr)); - } - TclFormatInt(buf, (*winSock.ntohs)(sockname.sin_port)); - Tcl_DStringAppendElement(dsPtr, buf); - if (len == 0) { - Tcl_DStringEndSublist(dsPtr); - } else { - return TCL_OK; - } - } else { - if (interp) { - TclWinConvertWSAError((*winSock.WSAGetLastError)()); - Tcl_AppendResult(interp, "can't get sockname: ", - Tcl_PosixError(interp), - (char *) NULL); - } - return TCL_ERROR; - } - } - - if (len > 0) { - return Tcl_BadChannelOption(interp, optionName, "peername sockname"); - } - - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TcpWatchProc -- - * - * Informs the channel driver of the events that the generic - * channel code wishes to receive on this socket. - * - * Results: - * None. - * - * Side effects: - * May cause the notifier to poll if any of the specified - * conditions are already true. - * - *---------------------------------------------------------------------- - */ - -static void -TcpWatchProc(instanceData, mask) - ClientData instanceData; /* The socket state. */ - int mask; /* Events of interest; an OR-ed - * combination of TCL_READABLE, - * TCL_WRITABLE and TCL_EXCEPTION. */ -{ - SocketInfo *infoPtr = (SocketInfo *) instanceData; - - /* - * Update the watch events mask. - */ - - infoPtr->watchEvents = 0; - if (mask & TCL_READABLE) { - infoPtr->watchEvents |= (FD_READ|FD_CLOSE|FD_ACCEPT); - } - if (mask & TCL_WRITABLE) { - infoPtr->watchEvents |= (FD_WRITE|FD_CONNECT); - } - - /* - * If there are any conditions already set, then tell the notifier to poll - * rather than block. - */ - - if (infoPtr->readyEvents & infoPtr->watchEvents) { - Tcl_Time blockTime = { 0, 0 }; - Tcl_SetMaxBlockTime(&blockTime); - } -} - -/* - *---------------------------------------------------------------------- - * - * TcpGetProc -- - * - * Called from Tcl_GetChannelHandle to retrieve an OS handle from inside - * a TCP socket based channel. - * - * Results: - * Returns TCL_OK with the socket in handlePtr. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -TcpGetHandleProc(instanceData, direction, handlePtr) - ClientData instanceData; /* The socket state. */ - int direction; /* Not used. */ - ClientData *handlePtr; /* Where to store the handle. */ -{ - SocketInfo *statePtr = (SocketInfo *) instanceData; - - *handlePtr = (ClientData) statePtr->socket; - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * SocketThread -- - * - * Helper thread used to manage the socket event handling window. - * - * Results: - * 1 if unable to create socket event window, 0 otherwise. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static DWORD WINAPI -SocketThread(LPVOID arg) -{ - MSG msg; - ThreadSpecificData *tsdPtr = (ThreadSpecificData *)(arg); - - tsdPtr->hwnd = CreateWindowA("TclSocket", "TclSocket", - WS_TILED, 0, 0, 0, 0, NULL, NULL, windowClass.hInstance, NULL); - - /* - * Signal the main thread that the window has been created - * and that the socket thread is ready to go. - */ - - SetEvent(tsdPtr->readyEvent); - - if (tsdPtr->hwnd == NULL) { - return 1; - } else { - /* - * store the tsdPtr, it's from a different thread, so it's - * not directly accessible, but needed. - */ - -#ifdef _WIN64 - SetWindowLongPtr(tsdPtr->hwnd, GWLP_USERDATA, (LONG) tsdPtr); -#else - SetWindowLong(tsdPtr->hwnd, GWL_USERDATA, (LONG) tsdPtr); -#endif - } - - while (1) { - /* - * Process all outstanding messages on the socket window. - */ - - while (PeekMessage(&msg, tsdPtr->hwnd, 0, 0, PM_REMOVE)) { - DispatchMessage(&msg); - } - WaitMessage(); - } -} - - -/* - *---------------------------------------------------------------------- - * - * SocketProc -- - * - * This function is called when WSAAsyncSelect has been used - * to register interest in a socket event, and the event has - * occurred. - * - * Results: - * 0 on success. - * - * Side effects: - * The flags for the given socket are updated to reflect the - * event that occured. - * - *---------------------------------------------------------------------- - */ - -static LRESULT CALLBACK -SocketProc(hwnd, message, wParam, lParam) - HWND hwnd; - UINT message; - WPARAM wParam; - LPARAM lParam; -{ - int event, error; - SOCKET socket; - SocketInfo *infoPtr; - ThreadSpecificData *tsdPtr = -#ifdef _WIN64 - (ThreadSpecificData *) GetWindowLongPtr(hwnd, GWLP_USERDATA); -#else - (ThreadSpecificData *) GetWindowLong(hwnd, GWL_USERDATA); -#endif - - switch (message) { - - default: - return DefWindowProc(hwnd, message, wParam, lParam); - break; - - case SOCKET_MESSAGE: - event = WSAGETSELECTEVENT(lParam); - error = WSAGETSELECTERROR(lParam); - socket = (SOCKET) wParam; - - /* - * Find the specified socket on the socket list and update its - * eventState flag. - */ - - WaitForSingleObject(tsdPtr->socketListLock, INFINITE); - for (infoPtr = tsdPtr->socketList; infoPtr != NULL; - infoPtr = infoPtr->nextPtr) { - if (infoPtr->socket == socket) { - /* - * Update the socket state. - */ - - /* - * A count of FD_ACCEPTS is stored, so if an FD_CLOSE event - * happens, then clear the FD_ACCEPT count. Otherwise, - * increment the count if the current event is and - * FD_ACCEPT. - */ - - if (event & FD_CLOSE) { - infoPtr->acceptEventCount = 0; - infoPtr->readyEvents &= ~(FD_WRITE|FD_ACCEPT); - } else if (event & FD_ACCEPT) { - infoPtr->acceptEventCount++; - } - - if (event & FD_CONNECT) { - /* - * The socket is now connected, - * clear the async connect flag. - */ - - infoPtr->flags &= ~(SOCKET_ASYNC_CONNECT); - - /* - * Remember any error that occurred so we can report - * connection failures. - */ - - if (error != ERROR_SUCCESS) { - TclWinConvertWSAError(error); - infoPtr->lastError = Tcl_GetErrno(); - } - - } - if(infoPtr->flags & SOCKET_ASYNC_CONNECT) { - infoPtr->flags &= ~(SOCKET_ASYNC_CONNECT); - if (error != ERROR_SUCCESS) { - TclWinConvertWSAError(error); - infoPtr->lastError = Tcl_GetErrno(); - } - infoPtr->readyEvents |= FD_WRITE; - } - infoPtr->readyEvents |= event; - - /* - * Wake up the Main Thread. - */ - SetEvent(tsdPtr->readyEvent); - Tcl_ThreadAlert(tsdPtr->threadId); - break; - } - } - SetEvent(tsdPtr->socketListLock); - break; - case SOCKET_SELECT: - infoPtr = (SocketInfo *) lParam; - if (wParam == SELECT) { - - (void) (*winSock.WSAAsyncSelect)(infoPtr->socket, hwnd, - SOCKET_MESSAGE, infoPtr->selectEvents); - } else { - /* - * Clear the selection mask - */ - - (void) (*winSock.WSAAsyncSelect)(infoPtr->socket, hwnd, 0, 0); - } - break; - case SOCKET_TERMINATE: - ExitThread(0); - break; - } - - return 0; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_GetHostName -- - * - * Returns the name of the local host. - * - * Results: - * A string containing the network name for this machine, or - * an empty string if we can't figure out the name. The caller - * must not modify or free this string. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -char * -Tcl_GetHostName() -{ - DWORD length; - WCHAR wbuf[MAX_COMPUTERNAME_LENGTH + 1]; - - Tcl_MutexLock(&socketMutex); - InitSockets(); - - if (hostnameInitialized) { - Tcl_MutexUnlock(&socketMutex); - return hostname; - } - Tcl_MutexUnlock(&socketMutex); - - if (TclpHasSockets(NULL) == TCL_OK) { - /* - * INTL: bug - */ - - if ((*winSock.gethostname)(hostname, sizeof(hostname)) == 0) { - Tcl_MutexLock(&socketMutex); - hostnameInitialized = 1; - Tcl_MutexUnlock(&socketMutex); - return hostname; - } - } - Tcl_MutexLock(&socketMutex); - length = sizeof(hostname); - if ((*tclWinProcs->getComputerNameProc)(wbuf, &length) != 0) { - /* - * Convert string from native to UTF then change to lowercase. - */ - - Tcl_DString ds; - - lstrcpynA(hostname, Tcl_WinTCharToUtf((TCHAR *) wbuf, -1, &ds), - sizeof(hostname)); - Tcl_DStringFree(&ds); - Tcl_UtfToLower(hostname); - } else { - hostname[0] = '\0'; - } - hostnameInitialized = 1; - Tcl_MutexUnlock(&socketMutex); - return hostname; -} - -/* - *---------------------------------------------------------------------- - * - * TclWinGetSockOpt, et al. -- - * - * These functions are wrappers that let us bind the WinSock - * API dynamically so we can run on systems that don't have - * the wsock32.dll. We need wrappers for these interfaces - * because they are called from the generic Tcl code. - * - * Results: - * As defined for each function. - * - * Side effects: - * As defined for each function. - * - *---------------------------------------------------------------------- - */ - -int -TclWinGetSockOpt(SOCKET s, int level, int optname, char * optval, - int FAR *optlen) -{ - /* - * Check that WinSock is initialized; do not call it if not, to - * prevent system crashes. This can happen at exit time if the exit - * handler for WinSock ran before other exit handlers that want to - * use sockets. - */ - - if (!SocketsEnabled()) { - return SOCKET_ERROR; - } - - return (*winSock.getsockopt)(s, level, optname, optval, optlen); -} - -int -TclWinSetSockOpt(SOCKET s, int level, int optname, const char * optval, - int optlen) -{ - /* - * Check that WinSock is initialized; do not call it if not, to - * prevent system crashes. This can happen at exit time if the exit - * handler for WinSock ran before other exit handlers that want to - * use sockets. - */ - if (!SocketsEnabled()) { - return SOCKET_ERROR; - } - - return (*winSock.setsockopt)(s, level, optname, optval, optlen); -} - -u_short -TclWinNToHS(u_short netshort) -{ - /* - * Check that WinSock is initialized; do not call it if not, to - * prevent system crashes. This can happen at exit time if the exit - * handler for WinSock ran before other exit handlers that want to - * use sockets. - */ - - if (!SocketsEnabled()) { - return (u_short) -1; - } - - return (*winSock.ntohs)(netshort); -} - -struct servent * -TclWinGetServByName(const char * name, const char * proto) -{ - /* - * Check that WinSock is initialized; do not call it if not, to - * prevent system crashes. This can happen at exit time if the exit - * handler for WinSock ran before other exit handlers that want to - * use sockets. - */ - if (!SocketsEnabled()) { - return (struct servent *) NULL; - } - - return (*winSock.getservbyname)(name, proto); -} - - diff --git a/win/tclWinTest.c b/win/tclWinTest.c deleted file mode 100644 index 07f198b..0000000 --- a/win/tclWinTest.c +++ /dev/null @@ -1,190 +0,0 @@ -/* - * tclWinTest.c -- - * - * Contains commands for platform specific tests on Windows. - * - * Copyright (c) 1996 Sun Microsystems, Inc. - * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclWinTest.c,v 1.4 1999/10/29 03:05:13 hobbs Exp $ - */ - -#include "tclWinInt.h" - -/* - * Forward declarations of procedures defined later in this file: - */ -int TclplatformtestInit _ANSI_ARGS_((Tcl_Interp *interp)); -static int TesteventloopCmd _ANSI_ARGS_((ClientData dummy, - Tcl_Interp *interp, int argc, char **argv)); -static int TestvolumetypeCmd _ANSI_ARGS_((ClientData dummy, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); - -/* - *---------------------------------------------------------------------- - * - * TclplatformtestInit -- - * - * Defines commands that test platform specific functionality for - * Unix platforms. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * Defines new commands. - * - *---------------------------------------------------------------------- - */ - -int -TclplatformtestInit(interp) - Tcl_Interp *interp; /* Interpreter to add commands to. */ -{ - /* - * Add commands for platform specific tests for Windows here. - */ - - Tcl_CreateCommand(interp, "testeventloop", TesteventloopCmd, - (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); - Tcl_CreateObjCommand(interp, "testvolumetype", TestvolumetypeCmd, - (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TesteventloopCmd -- - * - * This procedure implements the "testeventloop" command. It is - * used to test the Tcl notifier from an "external" event loop - * (i.e. not Tcl_DoOneEvent()). - * - * Results: - * A standard Tcl result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -TesteventloopCmd(clientData, interp, argc, argv) - ClientData clientData; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ -{ - static int *framePtr = NULL; /* Pointer to integer on stack frame of - * innermost invocation of the "wait" - * subcommand. */ - - if (argc < 2) { - Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], - " option ... \"", (char *) NULL); - return TCL_ERROR; - } - if (strcmp(argv[1], "done") == 0) { - *framePtr = 1; - } else if (strcmp(argv[1], "wait") == 0) { - int *oldFramePtr; - int done; - MSG msg; - int oldMode = Tcl_SetServiceMode(TCL_SERVICE_ALL); - - /* - * Save the old stack frame pointer and set up the current frame. - */ - - oldFramePtr = framePtr; - framePtr = &done; - - /* - * Enter a standard Windows event loop until the flag changes. - * Note that we do not explicitly call Tcl_ServiceEvent(). - */ - - done = 0; - while (!done) { - if (!GetMessage(&msg, NULL, 0, 0)) { - /* - * The application is exiting, so repost the quit message - * and start unwinding. - */ - - PostQuitMessage(msg.wParam); - break; - } - TranslateMessage(&msg); - DispatchMessage(&msg); - } - (void) Tcl_SetServiceMode(oldMode); - framePtr = oldFramePtr; - } else { - Tcl_AppendResult(interp, "bad option \"", argv[1], - "\": must be done or wait", (char *) NULL); - return TCL_ERROR; - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * Testvolumetype -- - * - * This procedure implements the "testvolumetype" command. It is - * used to check the volume type (FAT, NTFS) of a volume. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -TestvolumetypeCmd(clientData, interp, objc, objv) - ClientData clientData; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ -{ -#define VOL_BUF_SIZE 32 - int found; - char volType[VOL_BUF_SIZE]; - char *path; - - if (objc > 2) { - Tcl_WrongNumArgs(interp, 1, objv, "?name?"); - return TCL_ERROR; - } - if (objc == 2) { - /* - * path has to be really a proper volume, but we don't - * get query APIs for that until NT5 - */ - path = Tcl_GetString(objv[1]); - } else { - path = NULL; - } - found = GetVolumeInformationA(path, NULL, 0, NULL, NULL, - NULL, volType, VOL_BUF_SIZE); - - if (found == 0) { - Tcl_AppendResult(interp, "could not get volume type for \"", - (path?path:""), "\"", (char *) NULL); - TclWinConvertError(GetLastError()); - return TCL_ERROR; - } - Tcl_SetResult(interp, volType, TCL_VOLATILE); - return TCL_OK; -#undef VOL_BUF_SIZE -} diff --git a/win/tclWinThrd.c b/win/tclWinThrd.c deleted file mode 100644 index 8fe2596..0000000 --- a/win/tclWinThrd.c +++ /dev/null @@ -1,903 +0,0 @@ -/* - * tclWinThread.c -- - * - * This file implements the Windows-specific thread operations. - * - * Copyright (c) 1998 by Sun Microsystems, Inc. - * Copyright (c) 1999 by Scriptics Corporation - * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclWinThrd.c,v 1.8 2000/04/20 01:30:20 hobbs Exp $ - */ - -#include "tclWinInt.h" - -#include <dos.h> -#include <fcntl.h> -#include <io.h> -#include <sys/stat.h> - -/* - * This is the master lock used to serialize access to other - * serialization data structures. - */ - -static CRITICAL_SECTION masterLock; -static int init = 0; -#define MASTER_LOCK EnterCriticalSection(&masterLock) -#define MASTER_UNLOCK LeaveCriticalSection(&masterLock) - -/* - * This is the master lock used to serialize initialization and finalization - * of Tcl as a whole. - */ - -static CRITICAL_SECTION initLock; - -/* - * allocLock is used by Tcl's version of malloc for synchronization. - * For obvious reasons, cannot use any dyamically allocated storage. - */ - -static CRITICAL_SECTION allocLock; -static Tcl_Mutex allocLockPtr = (Tcl_Mutex) &allocLock; - -/* - * Condition variables are implemented with a combination of a - * per-thread Windows Event and a per-condition waiting queue. - * The idea is that each thread has its own Event that it waits - * on when it is doing a ConditionWait; it uses the same event for - * all condition variables because it only waits on one at a time. - * Each condition variable has a queue of waiting threads, and a - * mutex used to serialize access to this queue. - * - * Special thanks to David Nichols and - * Jim Davidson for advice on the Condition Variable implementation. - */ - -/* - * The per-thread event and queue pointers. - */ - -typedef struct ThreadSpecificData { - HANDLE condEvent; /* Per-thread condition event */ - struct ThreadSpecificData *nextPtr; /* Queue pointers */ - struct ThreadSpecificData *prevPtr; - int flags; /* See flags below */ -} ThreadSpecificData; -static Tcl_ThreadDataKey dataKey; - -/* - * State bits for the thread. - * WIN_THREAD_UNINIT Uninitialized. Must be zero because - * of the way ThreadSpecificData is created. - * WIN_THREAD_RUNNING Running, not waiting. - * WIN_THREAD_BLOCKED Waiting, or trying to wait. - * WIN_THREAD_DEAD Dying - no per-thread event anymore. - */ - -#define WIN_THREAD_UNINIT 0x0 -#define WIN_THREAD_RUNNING 0x1 -#define WIN_THREAD_BLOCKED 0x2 -#define WIN_THREAD_DEAD 0x4 - -/* - * The per condition queue pointers and the - * Mutex used to serialize access to the queue. - */ - -typedef struct WinCondition { - CRITICAL_SECTION condLock; /* Lock to serialize queuing on the condition */ - struct ThreadSpecificData *firstPtr; /* Queue pointers */ - struct ThreadSpecificData *lastPtr; -} WinCondition; - -static void FinalizeConditionEvent(ClientData data); - - -/* - *---------------------------------------------------------------------- - * - * Tcl_CreateThread -- - * - * This procedure creates a new thread. - * - * Results: - * TCL_OK if the thread could be created. The thread ID is - * returned in a parameter. - * - * Side effects: - * A new thread is created. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_CreateThread(idPtr, proc, clientData, stackSize, flags) - Tcl_ThreadId *idPtr; /* Return, the ID of the thread */ - Tcl_ThreadCreateProc proc; /* Main() function of the thread */ - ClientData clientData; /* The one argument to Main() */ - int stackSize; /* Size of stack for the new thread */ - int flags; /* Flags controlling behaviour of - * the new thread */ -{ - unsigned long code; - - code = _beginthreadex(NULL, stackSize, proc, clientData, 0, - (unsigned *)idPtr); - if (code == 0) { - return TCL_ERROR; - } else { - return TCL_OK; - } -} - -/* - *---------------------------------------------------------------------- - * - * TclpThreadExit -- - * - * This procedure terminates the current thread. - * - * Results: - * None. - * - * Side effects: - * This procedure terminates the current thread. - * - *---------------------------------------------------------------------- - */ - -void -TclpThreadExit(status) - int status; -{ - _endthreadex((DWORD)status); -} - - -/* - *---------------------------------------------------------------------- - * - * Tcl_GetCurrentThread -- - * - * This procedure returns the ID of the currently running thread. - * - * Results: - * A thread ID. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -Tcl_ThreadId -Tcl_GetCurrentThread() -{ - return (Tcl_ThreadId)GetCurrentThreadId(); -} - - -/* - *---------------------------------------------------------------------- - * - * TclpInitLock - * - * This procedure is used to grab a lock that serializes initialization - * and finalization of Tcl. On some platforms this may also initialize - * the mutex used to serialize creation of more mutexes and thread - * local storage keys. - * - * Results: - * None. - * - * Side effects: - * Acquire the initialization mutex. - * - *---------------------------------------------------------------------- - */ - -void -TclpInitLock() -{ - if (!init) { - /* - * There is a fundamental race here that is solved by creating - * the first Tcl interpreter in a single threaded environment. - * Once the interpreter has been created, it is safe to create - * more threads that create interpreters in parallel. - */ - init = 1; - InitializeCriticalSection(&initLock); - InitializeCriticalSection(&masterLock); - } - EnterCriticalSection(&initLock); -} - - -/* - *---------------------------------------------------------------------- - * - * TclpInitUnlock - * - * This procedure is used to release a lock that serializes initialization - * and finalization of Tcl. - * - * Results: - * None. - * - * Side effects: - * Release the initialization mutex. - * - *---------------------------------------------------------------------- - */ - -void -TclpInitUnlock() -{ - LeaveCriticalSection(&initLock); -} - - -/* - *---------------------------------------------------------------------- - * - * TclpMasterLock - * - * This procedure is used to grab a lock that serializes creation - * of mutexes, condition variables, and thread local storage keys. - * - * This lock must be different than the initLock because the - * initLock is held during creation of syncronization objects. - * - * Results: - * None. - * - * Side effects: - * Acquire the master mutex. - * - *---------------------------------------------------------------------- - */ - -void -TclpMasterLock() -{ - if (!init) { - /* - * There is a fundamental race here that is solved by creating - * the first Tcl interpreter in a single threaded environment. - * Once the interpreter has been created, it is safe to create - * more threads that create interpreters in parallel. - */ - init = 1; - InitializeCriticalSection(&initLock); - InitializeCriticalSection(&masterLock); - } - EnterCriticalSection(&masterLock); -} - - -/* - *---------------------------------------------------------------------- - * - * Tcl_GetAllocMutex - * - * This procedure returns a pointer to a statically initialized - * mutex for use by the memory allocator. The alloctor must - * use this lock, because all other locks are allocated... - * - * Results: - * A pointer to a mutex that is suitable for passing to - * Tcl_MutexLock and Tcl_MutexUnlock. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -Tcl_Mutex * -Tcl_GetAllocMutex() -{ -#ifdef TCL_THREADS - InitializeCriticalSection(&allocLock); - return &allocLockPtr; -#else - return NULL; -#endif -} - - -#ifdef TCL_THREADS -/* - *---------------------------------------------------------------------- - * - * TclpMasterUnlock - * - * This procedure is used to release a lock that serializes creation - * and deletion of synchronization objects. - * - * Results: - * None. - * - * Side effects: - * Release the master mutex. - * - *---------------------------------------------------------------------- - */ - -void -TclpMasterUnlock() -{ - LeaveCriticalSection(&masterLock); -} - - -/* - *---------------------------------------------------------------------- - * - * Tcl_MutexLock -- - * - * This procedure is invoked to lock a mutex. This is a self - * initializing mutex that is automatically finalized during - * Tcl_Finalize. - * - * Results: - * None. - * - * Side effects: - * May block the current thread. The mutex is aquired when - * this returns. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_MutexLock(mutexPtr) - Tcl_Mutex *mutexPtr; /* The lock */ -{ - CRITICAL_SECTION *csPtr; - if (*mutexPtr == NULL) { - MASTER_LOCK; - - /* - * Double inside master lock check to avoid a race. - */ - - if (*mutexPtr == NULL) { - csPtr = (CRITICAL_SECTION *)ckalloc(sizeof(CRITICAL_SECTION)); - InitializeCriticalSection(csPtr); - *mutexPtr = (Tcl_Mutex)csPtr; - TclRememberMutex(mutexPtr); - } - MASTER_UNLOCK; - } - csPtr = *((CRITICAL_SECTION **)mutexPtr); - EnterCriticalSection(csPtr); -} - - -/* - *---------------------------------------------------------------------- - * - * Tcl_MutexUnlock -- - * - * This procedure is invoked to unlock a mutex. - * - * Results: - * None. - * - * Side effects: - * The mutex is released when this returns. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_MutexUnlock(mutexPtr) - Tcl_Mutex *mutexPtr; /* The lock */ -{ - CRITICAL_SECTION *csPtr = *((CRITICAL_SECTION **)mutexPtr); - LeaveCriticalSection(csPtr); -} - - -/* - *---------------------------------------------------------------------- - * - * TclpFinalizeMutex -- - * - * This procedure is invoked to clean up one mutex. This is only - * safe to call at the end of time. - * - * Results: - * None. - * - * Side effects: - * The mutex list is deallocated. - * - *---------------------------------------------------------------------- - */ - -void -TclpFinalizeMutex(mutexPtr) - Tcl_Mutex *mutexPtr; -{ - CRITICAL_SECTION *csPtr = *(CRITICAL_SECTION **)mutexPtr; - if (csPtr != NULL) { - ckfree((char *)csPtr); - *mutexPtr = NULL; - } -} - - -/* - *---------------------------------------------------------------------- - * - * TclpThreadDataKeyInit -- - * - * This procedure initializes a thread specific data block key. - * Each thread has table of pointers to thread specific data. - * all threads agree on which table entry is used by each module. - * this is remembered in a "data key", that is just an index into - * this table. To allow self initialization, the interface - * passes a pointer to this key and the first thread to use - * the key fills in the pointer to the key. The key should be - * a process-wide static. - * - * Results: - * None. - * - * Side effects: - * Will allocate memory the first time this process calls for - * this key. In this case it modifies its argument - * to hold the pointer to information about the key. - * - *---------------------------------------------------------------------- - */ - -void -TclpThreadDataKeyInit(keyPtr) - Tcl_ThreadDataKey *keyPtr; /* Identifier for the data chunk, - * really (DWORD **) */ -{ - DWORD *indexPtr; - - MASTER_LOCK; - if (*keyPtr == NULL) { - indexPtr = (DWORD *)ckalloc(sizeof(DWORD)); - *indexPtr = TlsAlloc(); - *keyPtr = (Tcl_ThreadDataKey)indexPtr; - TclRememberDataKey(keyPtr); - } - MASTER_UNLOCK; -} - - -/* - *---------------------------------------------------------------------- - * - * TclpThreadDataKeyGet -- - * - * This procedure returns a pointer to a block of thread local storage. - * - * Results: - * A thread-specific pointer to the data structure, or NULL - * if the memory has not been assigned to this key for this thread. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -VOID * -TclpThreadDataKeyGet(keyPtr) - Tcl_ThreadDataKey *keyPtr; /* Identifier for the data chunk, - * really (DWORD **) */ -{ - DWORD *indexPtr = *(DWORD **)keyPtr; - if (indexPtr == NULL) { - return NULL; - } else { - return (VOID *) TlsGetValue(*indexPtr); - } -} - - -/* - *---------------------------------------------------------------------- - * - * TclpThreadDataKeySet -- - * - * This procedure sets the pointer to a block of thread local storage. - * - * Results: - * None. - * - * Side effects: - * Sets up the thread so future calls to TclpThreadDataKeyGet with - * this key will return the data pointer. - * - *---------------------------------------------------------------------- - */ - -void -TclpThreadDataKeySet(keyPtr, data) - Tcl_ThreadDataKey *keyPtr; /* Identifier for the data chunk, - * really (pthread_key_t **) */ - VOID *data; /* Thread local storage */ -{ - DWORD *indexPtr = *(DWORD **)keyPtr; - TlsSetValue(*indexPtr, (void *)data); -} - - -/* - *---------------------------------------------------------------------- - * - * TclpFinalizeThreadData -- - * - * This procedure cleans up the thread-local storage. This is - * called once for each thread. - * - * Results: - * None. - * - * Side effects: - * Frees up the memory. - * - *---------------------------------------------------------------------- - */ - -void -TclpFinalizeThreadData(keyPtr) - Tcl_ThreadDataKey *keyPtr; -{ - VOID *result; - DWORD *indexPtr; - - if (*keyPtr != NULL) { - indexPtr = *(DWORD **)keyPtr; - result = (VOID *)TlsGetValue(*indexPtr); - if (result != NULL) { - ckfree((char *)result); - TlsSetValue(*indexPtr, (void *)NULL); - } - } -} - -/* - *---------------------------------------------------------------------- - * - * TclpFinalizeThreadDataKey -- - * - * This procedure is invoked to clean up one key. This is a - * process-wide storage identifier. The thread finalization code - * cleans up the thread local storage itself. - * - * This assumes the master lock is held. - * - * Results: - * None. - * - * Side effects: - * The key is deallocated. - * - *---------------------------------------------------------------------- - */ - -void -TclpFinalizeThreadDataKey(keyPtr) - Tcl_ThreadDataKey *keyPtr; -{ - DWORD *indexPtr; - if (*keyPtr != NULL) { - indexPtr = *(DWORD **)keyPtr; - TlsFree(*indexPtr); - ckfree((char *)indexPtr); - *keyPtr = NULL; - } -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_ConditionWait -- - * - * This procedure is invoked to wait on a condition variable. - * The mutex is automically released as part of the wait, and - * automatically grabbed when the condition is signaled. - * - * The mutex must be held when this procedure is called. - * - * Results: - * None. - * - * Side effects: - * May block the current thread. The mutex is aquired when - * this returns. Will allocate memory for a HANDLE - * and initialize this the first time this Tcl_Condition is used. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_ConditionWait(condPtr, mutexPtr, timePtr) - Tcl_Condition *condPtr; /* Really (WinCondition **) */ - Tcl_Mutex *mutexPtr; /* Really (CRITICAL_SECTION **) */ - Tcl_Time *timePtr; /* Timeout on waiting period */ -{ - WinCondition *winCondPtr; /* Per-condition queue head */ - CRITICAL_SECTION *csPtr; /* Caller's Mutex, after casting */ - DWORD wtime; /* Windows time value */ - int timeout; /* True if we got a timeout */ - int doExit = 0; /* True if we need to do exit setup */ - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - - if (tsdPtr->flags & WIN_THREAD_DEAD) { - /* - * No more per-thread event on which to wait. - */ - - return; - } - - /* - * Self initialize the two parts of the contition. - * The per-condition and per-thread parts need to be - * handled independently. - */ - - if (tsdPtr->flags == WIN_THREAD_UNINIT) { - MASTER_LOCK; - - /* - * Create the per-thread event and queue pointers. - */ - - if (tsdPtr->flags == WIN_THREAD_UNINIT) { - tsdPtr->condEvent = CreateEvent(NULL, TRUE /* manual reset */, - FALSE /* non signaled */, NULL); - tsdPtr->nextPtr = NULL; - tsdPtr->prevPtr = NULL; - tsdPtr->flags = WIN_THREAD_RUNNING; - doExit = 1; - } - MASTER_UNLOCK; - - if (doExit) { - /* - * Create a per-thread exit handler to clean up the condEvent. - * We must be careful do do this outside the Master Lock - * because Tcl_CreateThreadExitHandler uses its own - * ThreadSpecificData, and initializing that may drop - * back into the Master Lock. - */ - - Tcl_CreateThreadExitHandler(FinalizeConditionEvent, - (ClientData) tsdPtr); - } - } - - if (*condPtr == NULL) { - MASTER_LOCK; - - /* - * Initialize the per-condition queue pointers and Mutex. - */ - - if (*condPtr == NULL) { - winCondPtr = (WinCondition *)ckalloc(sizeof(WinCondition)); - InitializeCriticalSection(&winCondPtr->condLock); - winCondPtr->firstPtr = NULL; - winCondPtr->lastPtr = NULL; - *condPtr = (Tcl_Condition)winCondPtr; - TclRememberCondition(condPtr); - } - MASTER_UNLOCK; - } - csPtr = *((CRITICAL_SECTION **)mutexPtr); - winCondPtr = *((WinCondition **)condPtr); - if (timePtr == NULL) { - wtime = INFINITE; - } else { - wtime = timePtr->sec * 1000 + timePtr->usec / 1000; - } - - /* - * Queue the thread on the condition, using - * the per-condition lock for serialization. - */ - - tsdPtr->flags = WIN_THREAD_BLOCKED; - tsdPtr->nextPtr = NULL; - EnterCriticalSection(&winCondPtr->condLock); - tsdPtr->prevPtr = winCondPtr->lastPtr; /* A: */ - winCondPtr->lastPtr = tsdPtr; - if (tsdPtr->prevPtr != NULL) { - tsdPtr->prevPtr->nextPtr = tsdPtr; - } - if (winCondPtr->firstPtr == NULL) { - winCondPtr->firstPtr = tsdPtr; - } - - /* - * Unlock the caller's mutex and wait for the condition, or a timeout. - * There is a minor issue here in that we don't count down the - * timeout if we get notified, but another thread grabs the condition - * before we do. In that race condition we'll wait again for the - * full timeout. Timed waits are dubious anyway. Either you have - * the locking protocol wrong and are masking a deadlock, - * or you are using conditions to pause your thread. - */ - - LeaveCriticalSection(csPtr); - timeout = 0; - while (!timeout && (tsdPtr->flags & WIN_THREAD_BLOCKED)) { - ResetEvent(tsdPtr->condEvent); - LeaveCriticalSection(&winCondPtr->condLock); - if (WaitForSingleObject(tsdPtr->condEvent, wtime) == WAIT_TIMEOUT) { - timeout = 1; - } - EnterCriticalSection(&winCondPtr->condLock); - } - - /* - * Be careful on timeouts because the signal might arrive right around - * time time limit and someone else could have taken us off the queue. - */ - - if (timeout) { - if (tsdPtr->flags & WIN_THREAD_RUNNING) { - timeout = 0; - } else { - /* - * When dequeuing, we can leave the tsdPtr->nextPtr - * and tsdPtr->prevPtr with dangling pointers because - * they are reinitialilzed w/out reading them when the - * thread is enqueued later. - */ - - if (winCondPtr->firstPtr == tsdPtr) { - winCondPtr->firstPtr = tsdPtr->nextPtr; - } else { - tsdPtr->prevPtr->nextPtr = tsdPtr->nextPtr; - } - if (winCondPtr->lastPtr == tsdPtr) { - winCondPtr->lastPtr = tsdPtr->prevPtr; - } else { - tsdPtr->nextPtr->prevPtr = tsdPtr->prevPtr; - } - tsdPtr->flags = WIN_THREAD_RUNNING; - } - } - - LeaveCriticalSection(&winCondPtr->condLock); - EnterCriticalSection(csPtr); -} - - -/* - *---------------------------------------------------------------------- - * - * Tcl_ConditionNotify -- - * - * This procedure is invoked to signal a condition variable. - * - * The mutex must be held during this call to avoid races, - * but this interface does not enforce that. - * - * Results: - * None. - * - * Side effects: - * May unblock another thread. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_ConditionNotify(condPtr) - Tcl_Condition *condPtr; -{ - WinCondition *winCondPtr; - ThreadSpecificData *tsdPtr; - if (condPtr != NULL) { - winCondPtr = *((WinCondition **)condPtr); - - /* - * Loop through all the threads waiting on the condition - * and notify them (i.e., broadcast semantics). The queue - * manipulation is guarded by the per-condition coordinating mutex. - */ - - EnterCriticalSection(&winCondPtr->condLock); - while (winCondPtr->firstPtr != NULL) { - tsdPtr = winCondPtr->firstPtr; - winCondPtr->firstPtr = tsdPtr->nextPtr; - if (winCondPtr->lastPtr == tsdPtr) { - winCondPtr->lastPtr = NULL; - } - tsdPtr->flags = WIN_THREAD_RUNNING; - tsdPtr->nextPtr = NULL; - tsdPtr->prevPtr = NULL; /* Not strictly necessary, see A: */ - SetEvent(tsdPtr->condEvent); - } - LeaveCriticalSection(&winCondPtr->condLock); - } else { - /* - * Noone has used the condition variable, so there are no waiters. - */ - } -} - - -/* - *---------------------------------------------------------------------- - * - * FinalizeConditionEvent -- - * - * This procedure is invoked to clean up the per-thread - * event used to implement condition waiting. - * This is only safe to call at the end of time. - * - * Results: - * None. - * - * Side effects: - * The per-thread event is closed. - * - *---------------------------------------------------------------------- - */ - -static void -FinalizeConditionEvent(data) - ClientData data; -{ - ThreadSpecificData *tsdPtr = (ThreadSpecificData *)data; - tsdPtr->flags = WIN_THREAD_DEAD; - CloseHandle(tsdPtr->condEvent); -} - -/* - *---------------------------------------------------------------------- - * - * TclpFinalizeCondition -- - * - * This procedure is invoked to clean up a condition variable. - * This is only safe to call at the end of time. - * - * This assumes the Master Lock is held. - * - * Results: - * None. - * - * Side effects: - * The condition variable is deallocated. - * - *---------------------------------------------------------------------- - */ - -void -TclpFinalizeCondition(condPtr) - Tcl_Condition *condPtr; -{ - WinCondition *winCondPtr = *(WinCondition **)condPtr; - - /* - * Note - this is called long after the thread-local storage is - * reclaimed. The per-thread condition waiting event is - * reclaimed earlier in a per-thread exit handler, which is - * called before thread local storage is reclaimed. - */ - - if (winCondPtr != NULL) { - ckfree((char *)winCondPtr); - *condPtr = NULL; - } -} -#endif /* TCL_THREADS */ diff --git a/win/tclWinThrd.h b/win/tclWinThrd.h deleted file mode 100644 index 2572d1b..0000000 --- a/win/tclWinThrd.h +++ /dev/null @@ -1,21 +0,0 @@ -/* - * tclWinThrd.h -- - * - * This header file defines things for thread support. - * - * Copyright (c) 1998 Sun Microsystems, Inc. - * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * SCCS: @(#) tclWinThrd.h 1.2 98/01/27 11:48:05 - */ - -#ifndef _TCLWINTHRD -#define _TCLWINTHRD - -#ifdef TCL_THREADS - -#endif /* TCL_THREADS */ - -#endif /* _TCLWINTHRD */ diff --git a/win/tclWinTime.c b/win/tclWinTime.c deleted file mode 100644 index db2affd..0000000 --- a/win/tclWinTime.c +++ /dev/null @@ -1,442 +0,0 @@ -/* - * tclWinTime.c -- - * - * Contains Windows specific versions of Tcl functions that - * obtain time values from the operating system. - * - * Copyright 1995-1998 by Sun Microsystems, Inc. - * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclWinTime.c,v 1.5 1999/12/01 00:08:43 hobbs Exp $ - */ - -#include "tclWinInt.h" - -#define SECSPERDAY (60L * 60L * 24L) -#define SECSPERYEAR (SECSPERDAY * 365L) -#define SECSPER4YEAR (SECSPERYEAR * 4L + SECSPERDAY) - -/* - * The following arrays contain the day of year for the last day of - * each month, where index 1 is January. - */ - -static int normalDays[] = { - -1, 30, 58, 89, 119, 150, 180, 211, 242, 272, 303, 333, 364 -}; - -static int leapDays[] = { - -1, 30, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334, 365 -}; - -typedef struct ThreadSpecificData { - char tzName[64]; /* Time zone name */ - struct tm tm; /* time information */ -} ThreadSpecificData; -static Tcl_ThreadDataKey dataKey; - -/* - * Declarations for functions defined later in this file. - */ - -static struct tm * ComputeGMT _ANSI_ARGS_((const time_t *tp)); - -/* - *---------------------------------------------------------------------- - * - * TclpGetSeconds -- - * - * This procedure returns the number of seconds from the epoch. - * On most Unix systems the epoch is Midnight Jan 1, 1970 GMT. - * - * Results: - * Number of seconds from the epoch. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -unsigned long -TclpGetSeconds() -{ - return (unsigned long) time((time_t *) NULL); -} - -/* - *---------------------------------------------------------------------- - * - * TclpGetClicks -- - * - * This procedure returns a value that represents the highest - * resolution clock available on the system. There are no - * guarantees on what the resolution will be. In Tcl we will - * call this value a "click". The start time is also system - * dependant. - * - * Results: - * Number of clicks from some start time. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -unsigned long -TclpGetClicks() -{ - return GetTickCount(); -} - -/* - *---------------------------------------------------------------------- - * - * TclpGetTimeZone -- - * - * Determines the current timezone. The method varies wildly - * between different Platform implementations, so its hidden in - * this function. - * - * Results: - * Minutes west of GMT. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -TclpGetTimeZone (currentTime) - unsigned long currentTime; -{ - int timeZone; - - tzset(); - timeZone = _timezone / 60; - - return timeZone; -} - -/* - *---------------------------------------------------------------------- - * - * TclpGetTime -- - * - * Gets the current system time in seconds and microseconds - * since the beginning of the epoch: 00:00 UCT, January 1, 1970. - * - * Results: - * Returns the current time in timePtr. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -void -TclpGetTime(timePtr) - Tcl_Time *timePtr; /* Location to store time information. */ -{ - struct timeb t; - - ftime(&t); - timePtr->sec = t.time; - timePtr->usec = t.millitm * 1000; -} - -/* - *---------------------------------------------------------------------- - * - * TclpGetTZName -- - * - * Gets the current timezone string. - * - * Results: - * Returns a pointer to a static string, or NULL on failure. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -char * -TclpGetTZName(int dst) -{ - int len; - char *zone, *p; - TIME_ZONE_INFORMATION tz; - Tcl_Encoding encoding; - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - char *name = tsdPtr->tzName; - - /* - * tzset() under Borland doesn't seem to set up tzname[] at all. - * tzset() under MSVC has the following weird observed behavior: - * First time we call "clock format [clock seconds] -format %Z -gmt 1" - * we get "GMT", but on all subsequent calls we get the current time - * zone string, even though env(TZ) is GMT and the variable _timezone - * is 0. - */ - - name[0] = '\0'; - - zone = getenv("TZ"); - if (zone != NULL) { - /* - * TZ is of form "NST-4:30NDT", where "NST" would be the - * name of the standard time zone for this area, "-4:30" is - * the offset from GMT in hours, and "NDT is the name of - * the daylight savings time zone in this area. The offset - * and DST strings are optional. - */ - - len = strlen(zone); - if (len > 3) { - len = 3; - } - if (dst != 0) { - /* - * Skip the offset string and get the DST string. - */ - - p = zone + len; - p += strspn(p, "+-:0123456789"); - if (*p != '\0') { - zone = p; - len = strlen(zone); - if (len > 3) { - len = 3; - } - } - } - Tcl_ExternalToUtf(NULL, NULL, zone, len, 0, NULL, name, - sizeof(tsdPtr->tzName), NULL, NULL, NULL); - } - if (name[0] == '\0') { - if (GetTimeZoneInformation(&tz) == TIME_ZONE_ID_UNKNOWN) { - /* - * MSDN: On NT this is returned if DST is not used in - * the current TZ - */ - dst = 0; - } - encoding = Tcl_GetEncoding(NULL, "unicode"); - Tcl_ExternalToUtf(NULL, encoding, - (char *) ((dst) ? tz.DaylightName : tz.StandardName), -1, - 0, NULL, name, sizeof(tsdPtr->tzName), NULL, NULL, NULL); - Tcl_FreeEncoding(encoding); - } - return name; -} - -/* - *---------------------------------------------------------------------- - * - * TclpGetDate -- - * - * This function converts between seconds and struct tm. If - * useGMT is true, then the returned date will be in Greenwich - * Mean Time (GMT). Otherwise, it will be in the local time zone. - * - * Results: - * Returns a static tm structure. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -struct tm * -TclpGetDate(t, useGMT) - TclpTime_t t; - int useGMT; -{ - const time_t *tp = (const time_t *) t; - struct tm *tmPtr; - long time; - - if (!useGMT) { - tzset(); - - /* - * If we are in the valid range, let the C run-time library - * handle it. Otherwise we need to fake it. Note that this - * algorithm ignores daylight savings time before the epoch. - */ - - if (*tp >= 0) { - return localtime(tp); - } - - time = *tp - _timezone; - - /* - * If we aren't near to overflowing the long, just add the bias and - * use the normal calculation. Otherwise we will need to adjust - * the result at the end. - */ - - if (*tp < (LONG_MAX - 2 * SECSPERDAY) - && *tp > (LONG_MIN + 2 * SECSPERDAY)) { - tmPtr = ComputeGMT(&time); - } else { - tmPtr = ComputeGMT(tp); - - tzset(); - - /* - * Add the bias directly to the tm structure to avoid overflow. - * Propagate seconds overflow into minutes, hours and days. - */ - - time = tmPtr->tm_sec - _timezone; - tmPtr->tm_sec = (int)(time % 60); - if (tmPtr->tm_sec < 0) { - tmPtr->tm_sec += 60; - time -= 60; - } - - time = tmPtr->tm_min + time/60; - tmPtr->tm_min = (int)(time % 60); - if (tmPtr->tm_min < 0) { - tmPtr->tm_min += 60; - time -= 60; - } - - time = tmPtr->tm_hour + time/60; - tmPtr->tm_hour = (int)(time % 24); - if (tmPtr->tm_hour < 0) { - tmPtr->tm_hour += 24; - time -= 24; - } - - time /= 24; - tmPtr->tm_mday += time; - tmPtr->tm_yday += time; - tmPtr->tm_wday = (tmPtr->tm_wday + time) % 7; - } - } else { - tmPtr = ComputeGMT(tp); - } - return tmPtr; -} - -/* - *---------------------------------------------------------------------- - * - * ComputeGMT -- - * - * This function computes GMT given the number of seconds since - * the epoch (midnight Jan 1 1970). - * - * Results: - * Returns a (per thread) statically allocated struct tm. - * - * Side effects: - * Updates the values of the static struct tm. - * - *---------------------------------------------------------------------- - */ - -static struct tm * -ComputeGMT(tp) - const time_t *tp; -{ - struct tm *tmPtr; - long tmp, rem; - int isLeap; - int *days; - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - - tmPtr = &tsdPtr->tm; - - /* - * Compute the 4 year span containing the specified time. - */ - - tmp = *tp / SECSPER4YEAR; - rem = *tp % SECSPER4YEAR; - - /* - * Correct for weird mod semantics so the remainder is always positive. - */ - - if (rem < 0) { - tmp--; - rem += SECSPER4YEAR; - } - - /* - * Compute the year after 1900 by taking the 4 year span and adjusting - * for the remainder. This works because 2000 is a leap year, and - * 1900/2100 are out of the range. - */ - - tmp = (tmp * 4) + 70; - isLeap = 0; - if (rem >= SECSPERYEAR) { /* 1971, etc. */ - tmp++; - rem -= SECSPERYEAR; - if (rem >= SECSPERYEAR) { /* 1972, etc. */ - tmp++; - rem -= SECSPERYEAR; - if (rem >= SECSPERYEAR + SECSPERDAY) { /* 1973, etc. */ - tmp++; - rem -= SECSPERYEAR + SECSPERDAY; - } else { - isLeap = 1; - } - } - } - tmPtr->tm_year = tmp; - - /* - * Compute the day of year and leave the seconds in the current day in - * the remainder. - */ - - tmPtr->tm_yday = rem / SECSPERDAY; - rem %= SECSPERDAY; - - /* - * Compute the time of day. - */ - - tmPtr->tm_hour = rem / 3600; - rem %= 3600; - tmPtr->tm_min = rem / 60; - tmPtr->tm_sec = rem % 60; - - /* - * Compute the month and day of month. - */ - - days = (isLeap) ? leapDays : normalDays; - for (tmp = 1; days[tmp] < tmPtr->tm_yday; tmp++) { - } - tmPtr->tm_mon = --tmp; - tmPtr->tm_mday = tmPtr->tm_yday - days[tmp]; - - /* - * Compute day of week. Epoch started on a Thursday. - */ - - tmPtr->tm_wday = (*tp / SECSPERDAY) + 4; - if ((*tp % SECSPERDAY) < 0) { - tmPtr->tm_wday--; - } - tmPtr->tm_wday %= 7; - if (tmPtr->tm_wday < 0) { - tmPtr->tm_wday += 7; - } - - return tmPtr; -} diff --git a/win/tclsh.ico b/win/tclsh.ico Binary files differdeleted file mode 100644 index 8bcaf48..0000000 --- a/win/tclsh.ico +++ /dev/null diff --git a/win/tclsh.rc b/win/tclsh.rc deleted file mode 100644 index 874abd7..0000000 --- a/win/tclsh.rc +++ /dev/null @@ -1,46 +0,0 @@ -// RCS: @(#) $Id: tclsh.rc,v 1.5 2000/04/18 23:26:45 redman Exp $ -// -// Version -// - -#define VS_VERSION_INFO 1 - -#define RESOURCE_INCLUDED -#include <tcl.h> - -LANGUAGE 0x9, 0x1 /* LANG_ENGLISH, SUBLANG_DEFAULT */ - -VS_VERSION_INFO VERSIONINFO - FILEVERSION TCL_MAJOR_VERSION,TCL_MINOR_VERSION,TCL_RELEASE_LEVEL,TCL_RELEASE_SERIAL - PRODUCTVERSION TCL_MAJOR_VERSION,TCL_MINOR_VERSION,TCL_RELEASE_LEVEL,TCL_RELEASE_SERIAL - FILEFLAGSMASK 0x3fL - FILEFLAGS 0x0L - FILEOS 0x4 /* VOS__WINDOWS32 */ - FILETYPE 0x2 /* VFT_DLL */ - FILESUBTYPE 0x0L -BEGIN - BLOCK "StringFileInfo" - BEGIN - BLOCK "040904b0" - BEGIN - VALUE "FileDescription", "Tclsh Application\0" - VALUE "OriginalFilename", "tclsh" STRINGIFY(TCL_MAJOR_VERSION) STRINGIFY(TCL_MINOR_VERSION) ".exe\0" - VALUE "CompanyName", "Scriptics Corporation\0" - VALUE "FileVersion", TCL_PATCH_LEVEL - VALUE "LegalCopyright", "Copyright (c) 2000 by Scriptics Corporation\0" - VALUE "ProductName", "Tcl " TCL_VERSION " for Windows\0" - VALUE "ProductVersion", TCL_PATCH_LEVEL - END - END - BLOCK "VarFileInfo" - BEGIN - VALUE "Translation", 0x409, 1200 - END -END - -// -// Icon -// - -tclsh ICON DISCARDABLE "tclsh.ico" - |