diff options
Diffstat (limited to 'unix')
45 files changed, 0 insertions, 19734 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; -} |