diff options
Diffstat (limited to 'unix')
39 files changed, 14849 insertions, 0 deletions
diff --git a/unix/Makefile.in b/unix/Makefile.in new file mode 100644 index 0000000..6b15ff5 --- /dev/null +++ b/unix/Makefile.in @@ -0,0 +1,1014 @@ +# +# 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. +# +# SCCS: @(#) Makefile.in 1.190 97/11/05 10:57:38 + +# Current Tcl version; used in various names. + +VERSION = @TCL_VERSION@ + +#---------------------------------------------------------------- +# Things you can change to personalize the Makefile for your own +# site (you can make these changes in either Makefile.in or +# Makefile, but changes to Makefile will get lost if you re-run +# the configuration script). +#---------------------------------------------------------------- + +# Default top-level directories in which to install architecture- +# specific files (exec_prefix) and machine-independent files such +# as scripts (prefix). The values specified here may be overridden +# at configure-time with the --exec-prefix and --prefix options +# to the "configure" script. + +prefix = @prefix@ +exec_prefix = @exec_prefix@ + +# The following definition can be set to non-null for special systems +# like AFS with replication. It allows the pathnames used for installation +# to be different than those used for actually reference files at +# run-time. INSTALL_ROOT is prepended to $prefix and $exec_prefix +# when installing files. +INSTALL_ROOT = + +# Directory from which applications will reference the library of Tcl +# scripts (note: you can set the TCL_LIBRARY environment variable at +# run-time to override this value): +TCL_LIBRARY = $(prefix)/lib/tcl$(VERSION) + +# Package search path. +TCL_PACKAGE_PATH = @TCL_PACKAGE_PATH@ + +# Path name to use when installing library scripts: +SCRIPT_INSTALL_DIR = $(INSTALL_ROOT)$(TCL_LIBRARY) + +# Directory in which to install libtcl.so or libtcl.a: +LIB_INSTALL_DIR = $(INSTALL_ROOT)$(exec_prefix)/lib + +# Path to use at runtime to refer to LIB_INSTALL_DIR: +LIB_RUNTIME_DIR = $(exec_prefix)/lib + +# Directory in which to install the program tclsh: +BIN_INSTALL_DIR = $(INSTALL_ROOT)$(exec_prefix)/bin + +# Directory in which to install the include file tcl.h: +INCLUDE_INSTALL_DIR = $(INSTALL_ROOT)$(prefix)/include + +# Top-level directory in which to install manual entries: +MAN_INSTALL_DIR = $(INSTALL_ROOT)$(prefix)/man + +# 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 + +# To change the compiler switches, for example to change from -O +# to -g, change the following line: +CFLAGS = -O + +# 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 +#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 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 + +# 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 symbol defines additional compiler flags to enable +# Tcl itself to be a shared library. If Tcl isn't going to be a +# shared library then the symbol has an empty definition. + +TCL_SHLIB_CFLAGS = @TCL_SHLIB_CFLAGS@ +#TCL_SHLIB_CFLAGS = + +# 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. + +SHLIB_LD = @SHLIB_LD@ + +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 + +#---------------------------------------------------------------- +# 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 = @DEFS@ +RANLIB = @RANLIB@ +SRC_DIR = @srcdir@ +TOP_DIR = @srcdir@/.. +GENERIC_DIR = $(TOP_DIR)/generic +COMPAT_DIR = $(TOP_DIR)/compat +TOOL_DIR = $(TOP_DIR)/tools +DLTEST_DIR = @srcdir@/dltest +UNIX_DIR = @srcdir@ +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} ${TCL_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 tclUnixTest.o + +XTTEST_OBJS = tclTest.o tclTestObj.o tclUnixTest.o tclXtNotify.o \ + tclXtTest.o xtTestInit.o + +GENERIC_OBJS = panic.o regexp.o tclAsync.o tclBasic.o tclBinary.o tclCkalloc.o \ + tclClock.o tclCmdAH.o tclCmdIL.o tclCmdMZ.o tclCompExpr.o \ + tclCompile.o tclDate.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 tclIOSock.o \ + tclIOUtil.o tclLink.o tclListObj.o tclLoad.o tclMain.o tclNamesp.o \ + tclNotify.o tclObj.o tclParse.o tclPipe.o tclPkg.o tclPosixStr.o \ + tclPreserve.o tclProc.o tclStringObj.o tclTimer.o tclUtil.o tclVar.o + +OBJS = ${GENERIC_OBJS} ${UNIX_OBJS} ${NOTIFY_OBJS} ${COMPAT_OBJS} @DL_OBJS@ + +GENERIC_HDRS = \ + $(GENERIC_DIR)/tclRegexp.h \ + $(GENERIC_DIR)/tcl.h \ + $(GENERIC_DIR)/tclInt.h \ + $(GENERIC_DIR)/tclPort.h \ + $(GENERIC_DIR)/tclPatch.h + +GENERIC_SRCS = \ + $(GENERIC_DIR)/regexp.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)/tclCompExpr.c \ + $(GENERIC_DIR)/tclCompile.c \ + $(GENERIC_DIR)/tclDate.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)/tclIOSock.c \ + $(GENERIC_DIR)/tclIOUtil.c \ + $(GENERIC_DIR)/tclLink.c \ + $(GENERIC_DIR)/tclListObj.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)/tclPipe.c \ + $(GENERIC_DIR)/tclPkg.c \ + $(GENERIC_DIR)/tclPosixStr.c \ + $(GENERIC_DIR)/tclPreserve.c \ + $(GENERIC_DIR)/tclProc.c \ + $(GENERIC_DIR)/tclStringObj.c \ + $(GENERIC_DIR)/tclTest.c \ + $(GENERIC_DIR)/tclTestObj.c \ + $(GENERIC_DIR)/tclTimer.c \ + $(GENERIC_DIR)/tclUtil.c \ + $(GENERIC_DIR)/tclVar.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)/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 \ + $(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) + +all: ${TCL_LIB_FILE} tclsh + +# The following target is configured by autoconf to generate either +# a shared library or non-shared library for Tcl. +${TCL_LIB_FILE}: ${OBJS} + rm -f ${TCL_LIB_FILE} + @MAKE_LIB@ + $(RANLIB) ${TCL_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} @LD_FLAGS@ ${TCLSH_OBJS} @TCL_BUILD_LIB_SPEC@ ${LIBS} \ + @TCL_LD_SEARCH_FLAGS@ -o tclsh + +tcltest: ${TCLTEST_OBJS} ${TCL_LIB_FILE} ${BUILD_DLTEST} + ${CC} @LD_FLAGS@ ${TCLTEST_OBJS} @TCL_BUILD_LIB_SPEC@ ${LIBS} \ + @TCL_LD_SEARCH_FLAGS@ -o tcltest + +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@ -lXt -o xttest + + +# 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; \ + TCL_LIBRARY=${TOP_DIR}/library; export TCL_LIBRARY; \ + ( echo cd $(TOP_DIR)/tests\; source all ) | ./tcltest + +# Useful target to launch a built tcltest with the proper path,... +runtest: + LD_LIBRARY_PATH=`pwd`:${LD_LIBRARY_PATH}; export LD_LIBRARY_PATH; \ + TCL_LIBRARY=${TOP_DIR}/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/%Z\% %M\% %I\% %E\% %U\%/g' \ + -e '/#ifdef __STDC__/,/#endif/d' -e '/TclDateerrlab:/d' \ + -e '/TclDatenewstate:/d' -e '/#pragma/d' \ + <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-man + +# 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: $(TCL_LIB_FILE) tclsh + @for i in $(LIB_INSTALL_DIR) $(BIN_INSTALL_DIR) ; \ + do \ + if [ ! -d $$i ] ; then \ + echo "Making directory $$i"; \ + mkdir $$i; \ + chmod 755 $$i; \ + else true; \ + fi; \ + done; + @echo "Installing $(TCL_LIB_FILE)" + @$(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) + @echo "Installing tclsh" + @$(INSTALL_PROGRAM) tclsh $(BIN_INSTALL_DIR)/tclsh$(VERSION) + @echo "Installing tclConfig.sh" + @$(INSTALL_DATA) tclConfig.sh $(LIB_INSTALL_DIR)/tclConfig.sh + +install-libraries: + @for i in $(INSTALL_ROOT)$(prefix)/lib $(INCLUDE_INSTALL_DIR) \ + $(SCRIPT_INSTALL_DIR); \ + do \ + if [ ! -d $$i ] ; then \ + echo "Making directory $$i"; \ + mkdir $$i; \ + chmod 755 $$i; \ + else true; \ + fi; \ + done; + @for i in http2.0 http1.0 opt0.1; \ + do \ + if [ ! -d $(SCRIPT_INSTALL_DIR)/$$i ] ; then \ + echo "Making directory $(SCRIPT_INSTALL_DIR)/$$i"; \ + mkdir $(SCRIPT_INSTALL_DIR)/$$i; \ + chmod 755 $(SCRIPT_INSTALL_DIR)/$$i; \ + else true; \ + fi; \ + done; + @echo "Installing tcl.h" + @$(INSTALL_DATA) $(GENERIC_DIR)/tcl.h $(INCLUDE_INSTALL_DIR)/tcl.h + @for i in $(TOP_DIR)/library/*.tcl $(TOP_DIR)/library/tclIndex $(UNIX_DIR)/tclAppInit.c $(UNIX_DIR)/ldAix; \ + do \ + echo "Installing $$i"; \ + $(INSTALL_DATA) $$i $(SCRIPT_INSTALL_DIR); \ + done; + @for i in http2.0 http1.0 opt0.1; \ + do \ + for j in $(TOP_DIR)/library/$$i/*.tcl ; \ + do \ + echo "Installing $$j"; \ + $(INSTALL_DATA) $$j $(SCRIPT_INSTALL_DIR)/$$i; \ + done; \ + done; + +install-man: + @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 $$i; \ + chmod 755 $$i; \ + else true; \ + fi; \ + done; + @cd $(TOP_DIR)/doc; for i in *.1; \ + do \ + echo "Installing doc/$$i"; \ + 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; + $(UNIX_DIR)/mkLinks $(MAN1_INSTALL_DIR) + @cd $(TOP_DIR)/doc; for i in *.3; \ + do \ + echo "Installing doc/$$i"; \ + 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; + $(UNIX_DIR)/mkLinks $(MAN3_INSTALL_DIR) + @cd $(TOP_DIR)/doc; for i in *.n; \ + do \ + echo "Installing doc/$$i"; \ + 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; + $(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 \ + SUNWtcl.* 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_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_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: + +panic.o: $(GENERIC_DIR)/panic.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/panic.c + +regexp.o: $(GENERIC_DIR)/regexp.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/regexp.c + +tclAppInit.o: $(UNIX_DIR)/tclAppInit.c + $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclAppInit.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 + +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 + +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 + +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 + +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 + +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 + +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 + +tclStringObj.o: $(GENERIC_DIR)/tclStringObj.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclStringObj.c + +tclUtil.o: $(GENERIC_DIR)/tclUtil.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclUtil.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 + +tclTimer.o: $(GENERIC_DIR)/tclTimer.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclTimer.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 + +tclUnixTime.o: $(UNIX_DIR)/tclUnixTime.c + $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclUnixTime.c + +tclUnixInit.o: $(UNIX_DIR)/tclUnixInit.c tclConfig.sh + $(CC) -c $(CC_SWITCHES) -DTCL_LIBRARY=\"${TCL_LIBRARY}\" \ + -DTCL_PACKAGE_PATH="\"${TCL_PACKAGE_PATH}\"" \ + $(UNIX_DIR)/tclUnixInit.c + +# compat binaries + +fixstrtod.o: $(COMPAT_DIR)/fixstrtod.c + $(CC) -c $(CC_SWITCHES) $(COMPAT_DIR)/fixstrtod.c + +getcwd.o: $(COMPAT_DIR)/getcwd.c + $(CC) -c $(CC_SWITCHES) $(COMPAT_DIR)/getcwd.c + +opendir.o: $(COMPAT_DIR)/opendir.c + $(CC) -c $(CC_SWITCHES) $(COMPAT_DIR)/opendir.c + +strncasecmp.o: $(COMPAT_DIR)/strncasecmp.c + $(CC) -c $(CC_SWITCHES) $(COMPAT_DIR)/strncasecmp.c + +strstr.o: $(COMPAT_DIR)/strstr.c + $(CC) -c $(CC_SWITCHES) $(COMPAT_DIR)/strstr.c + +strtod.o: $(COMPAT_DIR)/strtod.c + $(CC) -c $(CC_SWITCHES) $(COMPAT_DIR)/strtod.c + +strtol.o: $(COMPAT_DIR)/strtol.c + $(CC) -c $(CC_SWITCHES) $(COMPAT_DIR)/strtol.c + +strtoul.o: $(COMPAT_DIR)/strtoul.c + $(CC) -c $(CC_SWITCHES) $(COMPAT_DIR)/strtoul.c + +tmpnam.o: $(COMPAT_DIR)/tmpnam.c + $(CC) -c $(CC_SWITCHES) $(COMPAT_DIR)/tmpnam.c + +waitpid.o: $(COMPAT_DIR)/waitpid.c + $(CC) -c $(CC_SWITCHES) $(COMPAT_DIR)/waitpid.c + +.c.o: + $(CC) -c $(CC_SWITCHES) $< + +# +# 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 proper Tcl distribution from information in the +# master source directory. DISTDIR must be defined to indicate where +# to put the distribution. +# + +DISTNAME = tcl@TCL_VERSION@@TCL_PATCH_LEVEL@ +ZIPNAME = tcl@TCL_MAJOR_VERSION@@TCL_MINOR_VERSION@@TCL_PATCH_LEVEL@.zip +DISTDIR = /proj/tcl/dist/$(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 $(DISTDIR)/unix/tclXtNotify.c + cp $(UNIX_DIR)/Makefile.in $(DISTDIR)/unix + chmod 664 $(DISTDIR)/unix/Makefile.in + cp $(UNIX_DIR)/configure $(UNIX_DIR)/configure.in \ + $(UNIX_DIR)/tclConfig.sh.in $(UNIX_DIR)/install-sh \ + $(UNIX_DIR)/porting.notes $(UNIX_DIR)/porting.old \ + $(UNIX_DIR)/README $(UNIX_DIR)/ldAix \ + $(DISTDIR)/unix + chmod 775 $(DISTDIR)/unix/configure $(DISTDIR)/unix/configure.in + chmod 775 $(DISTDIR)/unix/ldAix + chmod +x $(DISTDIR)/unix/install-sh + tclsh $(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)/README $(DISTDIR)/generic + cp -p $(GENERIC_DIR)/tclGetDate.y $(DISTDIR)/generic + cp -p $(TOP_DIR)/changes $(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.0 http1.0 opt0.1; \ + do \ + mkdir $(DISTDIR)/library/$$i ;\ + cp -p $(TOP_DIR)/library/$$i/*.tcl $(DISTDIR)/library/$$i; \ + done; + 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/all $(TOP_DIR)/tests/remote.tcl \ + $(TOP_DIR)/tests/defs $(DISTDIR)/tests + mkdir $(DISTDIR)/win + cp -p $(TOP_DIR)/win/*.c $(TOP_DIR)/win/*.h $(TOP_DIR)/win/*.rc \ + $(DISTDIR)/win + cp -p $(TOP_DIR)/win/makefile.* $(DISTDIR)/win + cp -p $(TOP_DIR)/win/README $(DISTDIR)/win + cp -p $(TOP_DIR)/win/pkgIndex.tcl $(DISTDIR)/win + cp -p $(TOP_DIR)/license.terms $(DISTDIR)/win + mkdir $(DISTDIR)/mac + sccs edit -s $(TOP_DIR)/mac/tclMacProjects.sit.hqx + cp -p tclMacProjects.sit.hqx $(DISTDIR)/mac + sccs unedit $(TOP_DIR)/mac/tclMacProjects.sit.hqx + rm -f tclMacProjects.sit.hqx + 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 + +# +# The following target can only be used for non-patch releases. Use +# the "allpatch" target below for patch releases. +# + +alldist: dist + rm -f /proj/tcl/dist/$(DISTNAME).tar.Z \ + /proj/tcl/dist/$(DISTNAME).tar.gz \ + /proj/tcl/dist/$(ZIPNAME) + cd /proj/tcl/dist; tar cf $(DISTNAME).tar $(DISTNAME); \ + gzip -9 -c $(DISTNAME).tar > $(DISTNAME).tar.gz; \ + compress $(DISTNAME).tar; zip -r8 $(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 /proj/tcl/dist/$(DISTNAME).tar.Z \ + /proj/tcl/dist/$(DISTNAME).tar.gz \ + /proj/tcl/dist/$(ZIPNAME) + mv /proj/tcl/dist/tcl${VERSION} /proj/tcl/dist/old + mv /proj/tcl/dist/$(DISTNAME) /proj/tcl/dist/tcl${VERSION} + cd /proj/tcl/dist; tar cf $(DISTNAME).tar tcl${VERSION}; \ + gzip -9 -c $(DISTNAME).tar > $(DISTNAME).tar.gz; \ + compress $(DISTNAME).tar; zip -r8 $(ZIPNAME) tcl${VERSION} + mv /proj/tcl/dist/tcl${VERSION} /proj/tcl/dist/$(DISTNAME) + mv /proj/tcl/dist/old /proj/tcl/dist/tcl${VERSION} + +# +# 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 + rm -f $(DISTDIR)/mac/tclMacProjects.sit.hqx + tclsh $(TOOL_DIR)/man2html.tcl $(DISTDIR)/tmp ../.. tcl$(VERSION) + mv $(DISTDIR)/tmp/tcl$(VERSION) $(DISTDIR)/html + rm -rf $(DISTDIR)/doc + rm -rf $(DISTDIR)/tmp + tclsh $(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 SUNWtcl.sun4 and +# SUNWtcl.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: 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/SUNWtcl/$(VERSION) \ + --exec_prefix=/opt/SUNWtcl/$(VERSION)/`arch` \ + --enable-shared + mkdir -p $(DISTDIR)/SUNWtcl/$(VERSION) + mkdir -p $(DISTDIR)/SUNWtcl/$(VERSION)/`arch` + +# +# Build and install the architecture independent files in the dist directory. +# + +package-common: + cd $(DISTDIR)/unix/`arch`;\ + $(MAKE); \ + $(MAKE) prefix=$(DISTDIR)/SUNWtcl/$(VERSION) \ + exec_prefix=$(DISTDIR)/SUNWtcl/$(VERSION)/`arch` \ + install-libraries install-man + mkdir -p $(DISTDIR)/SUNWtcl/$(VERSION)/bin + sed -e "s/TCLVERSION/$(VERSION)/g" < $(UNIX_DIR)/tclsh.sh \ + > $(DISTDIR)/SUNWtcl/$(VERSION)/bin/tclsh$(VERSION) + chmod 755 $(DISTDIR)/SUNWtcl/$(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)/SUNWtcl/$(VERSION) \ + exec_prefix=$(DISTDIR)/SUNWtcl/$(VERSION)/`arch` + +# +# Generate a package from the installed files in the dist directory for the +# current architecture. +# + +package-generate: + pkgproto $(DISTDIR)/SUNWtcl/$(VERSION)/bin=bin \ + $(DISTDIR)/SUNWtcl/$(VERSION)/include=include \ + $(DISTDIR)/SUNWtcl/$(VERSION)/lib=lib \ + $(DISTDIR)/SUNWtcl/$(VERSION)/man=man \ + $(DISTDIR)/SUNWtcl/$(VERSION)/`arch`=`arch` \ + | tclsh $(UNIX_DIR)/mkProto.tcl \ + $(VERSION) $(UNIX_DIR) > prototype + pkgmk -o -d . -f prototype -a `arch` + pkgtrans -s . SUNWtcl.`arch` SUNWtcl + rm -rf SUNWtcl + +# DO NOT DELETE THIS LINE -- make depend depends on it. diff --git a/unix/README b/unix/README new file mode 100644 index 0000000..96c79c1 --- /dev/null +++ b/unix/README @@ -0,0 +1,110 @@ +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. + +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. + +SCCS: @(#) README 1.15 96/12/19 14:02:23 + +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) 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. + --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. + Note: be sure to use only absolute path names (those starting with "/") + in the --prefix and --exec_prefix options. + +(d) Type "make". This will create a library archive called "libtcl.a" + or "libtcl.so" and an interpreter application called "tclsh" that + allows you to type Tcl commands interactively or execute script files. + +(e) 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 file "porting.notes" to see if there are hints + for compiling on your system. Then look at the porting Web page + described later in this file. If you need to modify Makefile, there + are comments at the beginning of it that describe the things you + might want to change and how to change them. + +(f) 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. + +(g) 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.0" or "libtcl8.0.so"; + to use the installed versions, either specify the version number + or create a symbolic link (e.g. from "tclsh" to "tclsh8.0"). + +If you have trouble compiling Tcl, read through the file" porting.notes". +It contains information that people have provided about changes they had +to make to compile Tcl in various environments. Or, check out the +following Web URL: + http://www.sunlabs.com/cgi-bin/tcl/info.8.0 +This is an on-line database of porting information. We make no guarantees +that this information is accurate, complete, or up-to-date, but you may +find it useful. If you get Tcl running on a new configuration, we would +be happy to receive new information to add to "porting.notes". You can +also make a new entry into the on-line Web database. We're also interested +in hearing how to change the configuration setup so that Tcl compiles out +of the box on more platforms. + +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. + +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/configure.in b/unix/configure.in new file mode 100644 index 0000000..ee36dc4 --- /dev/null +++ b/unix/configure.in @@ -0,0 +1,1232 @@ +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) +# SCCS: @(#) configure.in 1.144 97/11/20 12:39:44 + +TCL_VERSION=8.0 +TCL_MAJOR_VERSION=8 +TCL_MINOR_VERSION=0 +TCL_PATCH_LEVEL="p2" +VERSION=${TCL_VERSION} + +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` + +AC_PROG_RANLIB +AC_ARG_ENABLE(gcc, [ --enable-gcc allow use of gcc if available], + [tcl_ok=$enableval], [tcl_ok=no]) +if test "$tcl_ok" = "yes"; then + AC_PROG_CC +else + CC=${CC-cc} +AC_SUBST(CC) +fi +AC_C_CROSS + +#-------------------------------------------------------------------- +# 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)) + +#-------------------------------------------------------------------- +# 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 +#-------------------------------------------------------------------- + +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) +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)) +AC_HAVE_HEADERS(unistd.h) + +#--------------------------------------------------------------------------- +# 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. +#--------------------------------------------------------------------------- + +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) + +#-------------------------------------------------------------------- +# 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. +#------------------------------------------------------------------------------ + +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 $libbsd = yes; then + AC_DEFINE(USE_DELTA_FOR_TZ) +fi + +#-------------------------------------------------------------------- +# Some systems (e.g., IRIX 4.0.5) lack the st_blksize field +# in struct stat. +#-------------------------------------------------------------------- +AC_STRUCT_ST_BLKSIZE + +#-------------------------------------------------------------------- +# 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. +#-------------------------------------------------------------------- + +AC_CHECK_FUNC(strtod, tcl_strtod=1, tcl_strtod=0) +if test "$tcl_strtod" = 1; then + AC_MSG_CHECKING([for Solaris strtod bug]) + AC_TRY_RUN([ +extern double strtod(); +int main() +{ + char *string = "NaN"; + char *term; + strtod(string, &term); + if ((term != string) && (term[-1] == 0)) { + 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 + +#-------------------------------------------------------------------- +# 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 to see whether the system provides a vfork kernel call. +# If not, then use fork instead. Also, check for a problem with +# vforks and signals that can cause core dumps if a vforked child +# resets a signal handler. If the problem exists, then use fork +# instead of vfork. +#-------------------------------------------------------------------- + +AC_CHECK_FUNC(vfork, tcl_ok=1, tcl_ok=0) +if test "$tcl_ok" = 1; then + AC_MSG_CHECKING([vfork/signal bug]); + AC_TRY_RUN([ +#include <stdio.h> +#include <signal.h> +#include <sys/wait.h> +int gotSignal = 0; +sigProc(sig) + int sig; +{ + gotSignal = 1; +} +main() +{ + int pid, sts; + (void) signal(SIGCHLD, sigProc); + pid = vfork(); + if (pid < 0) { + exit(1); + } else if (pid == 0) { + (void) signal(SIGCHLD, SIG_DFL); + _exit(0); + } else { + (void) wait(&sts); + } + exit((gotSignal) ? 0 : 1); +}], tcl_ok=1, tcl_ok=0, tcl_ok=0) + if test "$tcl_ok" = 1; then + AC_MSG_RESULT(ok) + else + AC_MSG_RESULT([buggy, using fork instead]) + fi +fi +rm -f core +if test "$tcl_ok" = 0; then + AC_DEFINE(vfork, fork) +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"])) + +#-------------------------------------------------------------------- +# The statements below define a collection of symbols related to +# dynamic loading and shared libraries: +# +# 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. +# LD_FLAGS - 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}. +#-------------------------------------------------------------------- + +# 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 + +# 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. + +fullSrcDir=`cd $srcdir; pwd` +TCL_SHARED_LIB_SUFFIX="" +TCL_UNSHARED_LIB_SUFFIX="" +TCL_LIB_VERSIONS_OK=ok +case $system in + AIX-4.[[2-9]]) + 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" + LD_FLAGS="" + LD_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}' + AIX=yes + TCL_SHARED_LIB_SUFFIX='${VERSION}.a' + ;; + AIX-*) + 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 tclLoadAix.o" + DL_LIBS="-lld" + LD_FLAGS="" + LD_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}' + TCL_SHARED_LIB_SUFFIX='${VERSION}.a' + ;; + 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" + LD_FLAGS="" + 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" + LD_FLAGS="" + LD_SEARCH_FLAGS="" + ;; + HP-UX-*.08.*|HP-UX-*.09.*|HP-UX-*.10.*) + 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="" + SHLIB_SUFFIX=".sl" + DL_OBJS="tclLoadShl.o" + DL_LIBS="-ldld" + LD_FLAGS="-Wl,-E" + LD_SEARCH_FLAGS='-Wl,+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="" + LD_FLAGS="-Wl,-D,08000000" + LD_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}' + TCL_SHARED_LIB_SUFFIX='${VERSION}.a' + ;; + IRIX-5.*|IRIX-6.*) + SHLIB_CFLAGS="" + SHLIB_LD="ld -shared -rdata_shared" + SHLIB_LD_LIBS="" + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadDl.o" + DL_LIBS="" + LD_FLAGS="" + LD_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' + ;; + IRIX64-6.*) + SHLIB_CFLAGS="" + SHLIB_LD="ld -32 -shared -rdata_shared -rpath /usr/local/lib" + SHLIB_LD_LIBS="" + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadDl.o" + DL_LIBS="" + LD_FLAGS="" + LD_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' + ;; + Linux*) + SHLIB_CFLAGS="-fPIC" + SHLIB_LD_LIBS="" + SHLIB_SUFFIX=".so" + if test "$have_dl" = yes; then + SHLIB_LD="${CC} -shared" + DL_OBJS="tclLoadDl.o" + DL_LIBS="-ldl" + LD_FLAGS="-rdynamic" + LD_SEARCH_FLAGS="" + else + AC_CHECK_HEADER(dld.h, [ + SHLIB_LD="ld -shared" + DL_OBJS="tclLoadDld.o" + DL_LIBS="-ldld" + LD_FLAGS="" + LD_SEARCH_FLAGS=""]) + 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" + LD_FLAGS="" + 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" + LD_FLAGS="-Wl,-Bexport" + LD_SEARCH_FLAGS="" + ;; + NetBSD-*|FreeBSD-*|OpenBSD-*) + # Not available on all versions: check for include file. + AC_CHECK_HEADER(dlfcn.h, [ + SHLIB_CFLAGS="-fpic" + SHLIB_LD="ld -Bshareable -x" + SHLIB_LD_LIBS="" + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadDl.o" + DL_LIBS="" + LD_FLAGS="" + LD_SEARCH_FLAGS="" + TCL_SHARED_LIB_SUFFIX='`echo ${VERSION} | tr -d .`.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="" + LD_FLAGS="" + LD_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}' + TCL_SHARED_LIB_SUFFIX='`echo ${VERSION} | tr -d .`.a' + ]) + + # FreeBSD doesn't handle version numbers with dots. + + TCL_UNSHARED_LIB_SUFFIX='`echo ${VERSION} | tr -d .`.a' + TCL_LIB_VERSIONS_OK=nodots + ;; + NEXTSTEP-*) + SHLIB_CFLAGS="" + SHLIB_LD="cc -nostdlib -r" + SHLIB_LD_LIBS="" + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadNext.o" + DL_LIBS="" + LD_FLAGS="" + LD_SEARCH_FLAGS="" + ;; + 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="" + LD_FLAGS="" + 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="" + LD_FLAGS="" + 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="" + LD_FLAGS="" + LD_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' + ;; + 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="" + LD_FLAGS="-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. + SHLIB_CFLAGS="-Kpic -belf" + SHLIB_LD="ld -G" + SHLIB_LD_LIBS="" + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadDl.o" + DL_LIBS="" + LD_FLAGS="-belf -Wl,-Bexport" + 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" + LD_FLAGS="" + LD_SEARCH_FLAGS="" + ;; + SunOS-4*) + SHLIB_CFLAGS="-PIC" + SHLIB_LD="ld" + SHLIB_LD_LIBS="" + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadDl.o" + DL_LIBS="-ldl" + LD_FLAGS="" + 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 + + TCL_SHARED_LIB_SUFFIX='`echo ${VERSION} | tr -d .`.so.1.0' + TCL_UNSHARED_LIB_SUFFIX='`echo ${VERSION} | tr -d .`.a' + TCL_LIB_VERSIONS_OK=nodots + ;; + SunOS-5*) + 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" + LD_FLAGS="" + LD_SEARCH_FLAGS='-R ${LIB_RUNTIME_DIR}' + ;; + 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="" + LD_FLAGS="-Wl,-D,08000000" + LD_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}' + ;; + UNIX_SV*) + 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 + LD_FLAGS="-Wl,-Bexport" + else + LD_FLAGS="" + fi + LD_SEARCH_FLAGS="" + ;; +esac + +# 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="" + LD_FLAGS="" + 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 "$CC" = "gcc" -o `$CC -v 2>&1 | grep -c gcc` != "0" ; then + case $system in + AIX-*) + ;; + BSD/OS*) + ;; + IRIX*) + ;; + NetBSD-*|FreeBSD-*|OpenBSD-*) + ;; + RISCos-*) + ;; + ULTRIX-4.*) + ;; + *) + SHLIB_CFLAGS="-fPIC" + ;; + esac + fi +fi + +#-------------------------------------------------------------------- +# 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. +#-------------------------------------------------------------------- + +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 + +#-------------------------------------------------------------------- +# The statements below define a collection of symbols related to +# building libtcl as a shared library instead of a static library. +#-------------------------------------------------------------------- + +realRanlib=$RANLIB +if test "$TCL_SHARED_LIB_SUFFIX" = "" ; then + TCL_SHARED_LIB_SUFFIX='${VERSION}${SHLIB_SUFFIX}' +fi +if test "$TCL_UNSHARED_LIB_SUFFIX" = "" ; then + TCL_UNSHARED_LIB_SUFFIX='${VERSION}.a' +fi +AC_ARG_ENABLE(shared, + [ --enable-shared build libtcl as a shared library], + [tcl_ok=$enableval], [tcl_ok=no]) +if test "$tcl_ok" = "yes" -a "${SHLIB_SUFFIX}" != "" ; then + TCL_SHARED_BUILD=1 + 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 + TCL_SHARED_BUILD=0 + case $system in + BSD/OS*) + ;; + + AIX-*) + ;; + + *) + SHLIB_LD_LIBS="" + ;; + esac + TCL_SHLIB_CFLAGS="" + TCL_LD_SEARCH_FLAGS="" + eval "TCL_LIB_FILE=libtcl${TCL_UNSHARED_LIB_SUFFIX}" + MAKE_LIB="ar cr ${TCL_LIB_FILE} \${OBJS}" +fi + +# 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 "${TCL_LIB_VERSIONS_OK}" = "ok"; then + TCL_BUILD_LIB_SPEC="-L`pwd` -ltcl${VERSION}" + TCL_LIB_SPEC="-L${exec_prefix}/lib -ltcl${VERSION}" +else + TCL_BUILD_LIB_SPEC="-L`pwd` -ltcl`echo ${VERSION} | tr -d .`" + TCL_LIB_SPEC="-L${exec_prefix}/lib -ltcl`echo ${VERSION} | tr -d .`" +fi + +#-------------------------------------------------------------------- +# 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 + +AC_SUBST(BUILD_DLTEST) +AC_SUBST(DL_LIBS) +AC_SUBST(DL_OBJS) +AC_SUBST(LD_FLAGS) +AC_SUBST(MAKE_LIB) +AC_SUBST(MATH_LIBS) +AC_SUBST(SHLIB_CFLAGS) +AC_SUBST(SHLIB_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_LIB_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_SHARED_BUILD) +AC_SUBST(TCL_SHLIB_CFLAGS) +AC_SUBST(TCL_SRC_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 new file mode 100644 index 0000000..2197b4b --- /dev/null +++ b/unix/dltest/Makefile.in @@ -0,0 +1,45 @@ +# 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. +# SCCS: @(#) Makefile.in 1.12 97/02/22 14:13:54 + +CC = @CC@ +LIBS = @TCL_BUILD_LIB_SPEC@ @TCL_LIBS@ -lc +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} + +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 @SHLIB_LD_LIBS@ + +pkgb${SHLIB_SUFFIX}: $(SRC_DIR)/pkgb.c + $(CC) -c $(CC_SWITCHES) $(SRC_DIR)/pkgb.c + ${SHLIB_LD} -o pkgb${SHLIB_SUFFIX} pkgb.o @SHLIB_LD_LIBS@ + +pkgc${SHLIB_SUFFIX}: $(SRC_DIR)/pkgc.c + $(CC) -c $(CC_SWITCHES) $(SRC_DIR)/pkgc.c + ${SHLIB_LD} -o pkgc${SHLIB_SUFFIX} pkgc.o @SHLIB_LD_LIBS@ + +pkgd${SHLIB_SUFFIX}: $(SRC_DIR)/pkgd.c + $(CC) -c $(CC_SWITCHES) $(SRC_DIR)/pkgd.c + ${SHLIB_LD} -o pkgd${SHLIB_SUFFIX} pkgd.o @SHLIB_LD_LIBS@ + +pkge${SHLIB_SUFFIX}: $(SRC_DIR)/pkge.c + $(CC) -c $(CC_SWITCHES) $(SRC_DIR)/pkge.c + ${SHLIB_LD} -o pkge${SHLIB_SUFFIX} pkge.o @SHLIB_LD_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 new file mode 100644 index 0000000..f4e54d4 --- /dev/null +++ b/unix/dltest/README @@ -0,0 +1,12 @@ +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. + +sccsid: @(#) README 1.2 95/08/22 08:13:23 diff --git a/unix/dltest/configure.in b/unix/dltest/configure.in new file mode 100644 index 0000000..29924e9 --- /dev/null +++ b/unix/dltest/configure.in @@ -0,0 +1,29 @@ +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) +# SCCS: @(#) configure.in 1.9 96/04/15 09:50:20 + +# 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) +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_LIB_SPEC) +TCL_LIBS=$TCL_LIBS +AC_SUBST(TCL_LIBS) +TCL_VERSION=$TCL_VERSION +AC_SUBST(TCL_VERSION) + +AC_OUTPUT(Makefile) diff --git a/unix/dltest/pkga.c b/unix/dltest/pkga.c new file mode 100644 index 0000000..ab48522 --- /dev/null +++ b/unix/dltest/pkga.c @@ -0,0 +1,130 @@ +/* + * 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. + * + * SCCS: @(#) pkga.c 1.4 96/02/15 12:30:35 + */ +#include "tcl.h" + +/* + * Prototypes for procedures defined later in this file: + */ + +static int Pkga_EqCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +static int Pkga_QuoteCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); + +/* + *---------------------------------------------------------------------- + * + * Pkga_EqCmd -- + * + * 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_EqCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " string1 string2\"", (char *) NULL); + return TCL_ERROR; + } + + if (strcmp(argv[1], argv[2]) == 0) { + interp->result = "1"; + } else { + interp->result = "0"; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Pkga_quoteCmd -- + * + * 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_QuoteCmd(dummy, interp, argc, argv) + ClientData dummy; /* 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], + " value\"", (char *) NULL); + return TCL_ERROR; + } + strcpy(interp->result, argv[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; + + code = Tcl_PkgProvide(interp, "Pkga", "1.0"); + if (code != TCL_OK) { + return code; + } + Tcl_CreateCommand(interp, "pkga_eq", Pkga_EqCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "pkga_quote", Pkga_QuoteCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + return TCL_OK; +} diff --git a/unix/dltest/pkgb.c b/unix/dltest/pkgb.c new file mode 100644 index 0000000..1da9575 --- /dev/null +++ b/unix/dltest/pkgb.c @@ -0,0 +1,153 @@ +/* + * 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. + * + * SCCS: @(#) pkgb.c 1.4 96/02/15 12:30:34 + */ +#include "tcl.h" + +/* + * Prototypes for procedures defined later in this file: + */ + +static int Pkgb_SubCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +static int Pkgb_UnsafeCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); + +/* + *---------------------------------------------------------------------- + * + * Pkgb_SubCmd -- + * + * 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_SubCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int first, second; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " num num\"", (char *) NULL); + return TCL_ERROR; + } + if ((Tcl_GetInt(interp, argv[1], &first) != TCL_OK) + || (Tcl_GetInt(interp, argv[2], &second) != TCL_OK)) { + return TCL_ERROR; + } + sprintf(interp->result, "%d", first - second); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Pkgb_UnsafeCmd -- + * + * 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_UnsafeCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + interp->result = "unsafe command invoked"; + 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; + + code = Tcl_PkgProvide(interp, "Pkgb", "2.3"); + if (code != TCL_OK) { + return code; + } + Tcl_CreateCommand(interp, "pkgb_sub", Pkgb_SubCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "pkgb_unsafe", Pkgb_UnsafeCmd, (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. */ +{ + Tcl_CreateCommand(interp, "pkgb_sub", Pkgb_SubCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + return TCL_OK; +} diff --git a/unix/dltest/pkgc.c b/unix/dltest/pkgc.c new file mode 100644 index 0000000..c35189a --- /dev/null +++ b/unix/dltest/pkgc.c @@ -0,0 +1,153 @@ +/* + * 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. + * + * SCCS: @(#) pkgc.c 1.4 96/02/15 12:30:35 + */ +#include "tcl.h" + +/* + * Prototypes for procedures defined later in this file: + */ + +static int Pkgc_SubCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +static int Pkgc_UnsafeCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); + +/* + *---------------------------------------------------------------------- + * + * Pkgc_SubCmd -- + * + * 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_SubCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int first, second; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " num num\"", (char *) NULL); + return TCL_ERROR; + } + if ((Tcl_GetInt(interp, argv[1], &first) != TCL_OK) + || (Tcl_GetInt(interp, argv[2], &second) != TCL_OK)) { + return TCL_ERROR; + } + sprintf(interp->result, "%d", 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_UnsafeCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + interp->result = "unsafe command invoked"; + 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; + + code = Tcl_PkgProvide(interp, "Pkgc", "1.7.2"); + if (code != TCL_OK) { + return code; + } + Tcl_CreateCommand(interp, "pkgc_sub", Pkgc_SubCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "pkgc_unsafe", Pkgc_UnsafeCmd, (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. */ +{ + Tcl_CreateCommand(interp, "pkgc_sub", Pkgc_SubCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + return TCL_OK; +} diff --git a/unix/dltest/pkgd.c b/unix/dltest/pkgd.c new file mode 100644 index 0000000..56821cc --- /dev/null +++ b/unix/dltest/pkgd.c @@ -0,0 +1,154 @@ +/* + * 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. + * + * SCCS: @(#) pkgd.c 1.4 96/02/15 12:30:32 + */ + +#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)); + +/* + *---------------------------------------------------------------------- + * + * Pkgd_SubCmd -- + * + * 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_SubCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int first, second; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " num num\"", (char *) NULL); + return TCL_ERROR; + } + if ((Tcl_GetInt(interp, argv[1], &first) != TCL_OK) + || (Tcl_GetInt(interp, argv[2], &second) != TCL_OK)) { + return TCL_ERROR; + } + sprintf(interp->result, "%d", 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_UnsafeCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + interp->result = "unsafe command invoked"; + 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; + + code = Tcl_PkgProvide(interp, "Pkgd", "7.3"); + if (code != TCL_OK) { + return code; + } + Tcl_CreateCommand(interp, "pkgd_sub", Pkgd_SubCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "pkgd_unsafe", Pkgd_UnsafeCmd, (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. */ +{ + Tcl_CreateCommand(interp, "pkgd_sub", Pkgd_SubCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + return TCL_OK; +} diff --git a/unix/dltest/pkge.c b/unix/dltest/pkge.c new file mode 100644 index 0000000..1d585ca --- /dev/null +++ b/unix/dltest/pkge.c @@ -0,0 +1,49 @@ +/* + * 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. + * + * SCCS: @(#) pkge.c 1.5 96/03/07 09:34:27 + */ +#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)); + +/* + *---------------------------------------------------------------------- + * + * 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. */ +{ + return Tcl_Eval(interp, "if 44 {open non_existent}"); +} diff --git a/unix/dltest/pkgf.c b/unix/dltest/pkgf.c new file mode 100644 index 0000000..d7c641a --- /dev/null +++ b/unix/dltest/pkgf.c @@ -0,0 +1,49 @@ +/* + * 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. + * + * SCCS: @(#) pkgf.c 1.2 96/02/15 12:30:32 + */ +#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. */ +{ + return Tcl_Eval(interp, "if 44 {open non_existent}"); +} diff --git a/unix/install-sh b/unix/install-sh new file mode 100755 index 0000000..0ff4b6a --- /dev/null +++ b/unix/install-sh @@ -0,0 +1,119 @@ +#!/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 new file mode 100755 index 0000000..4da2b20 --- /dev/null +++ b/unix/ldAix @@ -0,0 +1,72 @@ +#!/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. +# +# SCCS: @(#) ldAix 1.8 97/02/21 14:50:27 + +# 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 + +# 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 "#! " >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 + +# Extract the name of the object file that we're linking. If it's 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 new file mode 100644 index 0000000..b4da360 --- /dev/null +++ b/unix/mkLinks @@ -0,0 +1,1010 @@ +#!/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 safe.n; then + rm -f Base.n + ln safe.n Base.n +fi +if test -r http.n; then + rm -f Http.n + ln http.n Http.n +fi +if test -r safe.n; then + rm -f Safe.n + ln safe.n Safe.n +fi +if test -r StringObj.3; then + rm -f TclConcatObj.3 + ln StringObj.3 TclConcatObj.3 +fi +if test -r AddErrInfo.3; then + rm -f Tcl_AddErrorInfo.3 + ln AddErrInfo.3 Tcl_AddErrorInfo.3 +fi +if test -r AddErrInfo.3; then + rm -f Tcl_AddObjErrorInfo.3 + ln AddErrInfo.3 Tcl_AddObjErrorInfo.3 +fi +if test -r Alloc.3; then + rm -f Tcl_Alloc.3 + ln Alloc.3 Tcl_Alloc.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 ObjectType.3; then + rm -f Tcl_AppendAllObjTypes.3 + ln ObjectType.3 Tcl_AppendAllObjTypes.3 +fi +if test -r SetResult.3; then + rm -f Tcl_AppendElement.3 + ln SetResult.3 Tcl_AppendElement.3 +fi +if test -r SetResult.3; then + rm -f Tcl_AppendResult.3 + ln SetResult.3 Tcl_AppendResult.3 +fi +if test -r StringObj.3; then + rm -f Tcl_AppendStringsToObj.3 + ln StringObj.3 Tcl_AppendStringsToObj.3 +fi +if test -r StringObj.3; then + rm -f Tcl_AppendToObj.3 + ln StringObj.3 Tcl_AppendToObj.3 +fi +if test -r Async.3; then + rm -f Tcl_AsyncCreate.3 + ln Async.3 Tcl_AsyncCreate.3 +fi +if test -r Async.3; then + rm -f Tcl_AsyncDelete.3 + ln Async.3 Tcl_AsyncDelete.3 +fi +if test -r Async.3; then + rm -f Tcl_AsyncInvoke.3 + ln Async.3 Tcl_AsyncInvoke.3 +fi +if test -r Async.3; then + rm -f Tcl_AsyncMark.3 + ln Async.3 Tcl_AsyncMark.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 CrtChannel.3; then + rm -f Tcl_BadChannelOption.3 + ln CrtChannel.3 Tcl_BadChannelOption.3 +fi +if test -r CallDel.3; then + rm -f Tcl_CallWhenDeleted.3 + ln CallDel.3 Tcl_CallWhenDeleted.3 +fi +if test -r DoWhenIdle.3; then + rm -f Tcl_CancelIdleCall.3 + ln DoWhenIdle.3 Tcl_CancelIdleCall.3 +fi +if test -r OpenFileChnl.3; then + rm -f Tcl_Close.3 + ln OpenFileChnl.3 Tcl_Close.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 SplitList.3; then + rm -f Tcl_ConvertElement.3 + ln SplitList.3 Tcl_ConvertElement.3 +fi +if test -r ObjectType.3; then + rm -f Tcl_ConvertToType.3 + ln ObjectType.3 Tcl_ConvertToType.3 +fi +if test -r CrtSlave.3; then + rm -f Tcl_CreateAlias.3 + ln CrtSlave.3 Tcl_CreateAlias.3 +fi +if test -r CrtSlave.3; then + rm -f Tcl_CreateAliasObj.3 + ln CrtSlave.3 Tcl_CreateAliasObj.3 +fi +if test -r CrtChannel.3; then + rm -f Tcl_CreateChannel.3 + ln CrtChannel.3 Tcl_CreateChannel.3 +fi +if test -r CrtChnlHdlr.3; then + rm -f Tcl_CreateChannelHandler.3 + ln CrtChnlHdlr.3 Tcl_CreateChannelHandler.3 +fi +if test -r CrtCloseHdlr.3; then + rm -f Tcl_CreateCloseHandler.3 + ln CrtCloseHdlr.3 Tcl_CreateCloseHandler.3 +fi +if test -r CrtCommand.3; then + rm -f Tcl_CreateCommand.3 + ln CrtCommand.3 Tcl_CreateCommand.3 +fi +if test -r Notifier.3; then + rm -f Tcl_CreateEventSource.3 + ln Notifier.3 Tcl_CreateEventSource.3 +fi +if test -r Exit.3; then + rm -f Tcl_CreateExitHandler.3 + ln Exit.3 Tcl_CreateExitHandler.3 +fi +if test -r CrtFileHdlr.3; then + rm -f Tcl_CreateFileHandler.3 + ln CrtFileHdlr.3 Tcl_CreateFileHandler.3 +fi +if test -r Hash.3; then + rm -f Tcl_CreateHashEntry.3 + ln Hash.3 Tcl_CreateHashEntry.3 +fi +if test -r CrtInterp.3; then + rm -f Tcl_CreateInterp.3 + ln CrtInterp.3 Tcl_CreateInterp.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 + ln CrtObjCmd.3 Tcl_CreateObjCommand.3 +fi +if test -r CrtSlave.3; then + rm -f Tcl_CreateSlave.3 + ln CrtSlave.3 Tcl_CreateSlave.3 +fi +if test -r CrtTimerHdlr.3; then + rm -f Tcl_CreateTimerHandler.3 + ln CrtTimerHdlr.3 Tcl_CreateTimerHandler.3 +fi +if test -r CrtTrace.3; then + rm -f Tcl_CreateTrace.3 + ln CrtTrace.3 Tcl_CreateTrace.3 +fi +if test -r DString.3; then + rm -f Tcl_DStringAppend.3 + ln DString.3 Tcl_DStringAppend.3 +fi +if test -r DString.3; then + rm -f Tcl_DStringAppendElement.3 + ln DString.3 Tcl_DStringAppendElement.3 +fi +if test -r DString.3; then + rm -f Tcl_DStringEndSublist.3 + ln DString.3 Tcl_DStringEndSublist.3 +fi +if test -r DString.3; then + rm -f Tcl_DStringFree.3 + ln DString.3 Tcl_DStringFree.3 +fi +if test -r DString.3; then + rm -f Tcl_DStringGetResult.3 + ln DString.3 Tcl_DStringGetResult.3 +fi +if test -r DString.3; then + rm -f Tcl_DStringInit.3 + ln DString.3 Tcl_DStringInit.3 +fi +if test -r DString.3; then + rm -f Tcl_DStringLength.3 + ln DString.3 Tcl_DStringLength.3 +fi +if test -r DString.3; then + rm -f Tcl_DStringResult.3 + ln DString.3 Tcl_DStringResult.3 +fi +if test -r DString.3; then + rm -f Tcl_DStringSetLength.3 + ln DString.3 Tcl_DStringSetLength.3 +fi +if test -r DString.3; then + rm -f Tcl_DStringStartSublist.3 + ln DString.3 Tcl_DStringStartSublist.3 +fi +if test -r DString.3; then + rm -f Tcl_DStringValue.3 + ln DString.3 Tcl_DStringValue.3 +fi +if test -r Object.3; then + rm -f Tcl_DecrRefCount.3 + ln Object.3 Tcl_DecrRefCount.3 +fi +if test -r AssocData.3; then + rm -f Tcl_DeleteAssocData.3 + ln AssocData.3 Tcl_DeleteAssocData.3 +fi +if test -r CrtChnlHdlr.3; then + rm -f Tcl_DeleteChannelHandler.3 + ln CrtChnlHdlr.3 Tcl_DeleteChannelHandler.3 +fi +if test -r CrtCloseHdlr.3; then + rm -f Tcl_DeleteCloseHandler.3 + ln CrtCloseHdlr.3 Tcl_DeleteCloseHandler.3 +fi +if test -r CrtObjCmd.3; then + rm -f Tcl_DeleteCommand.3 + ln CrtObjCmd.3 Tcl_DeleteCommand.3 +fi +if test -r CrtObjCmd.3; then + rm -f Tcl_DeleteCommandFromToken.3 + ln CrtObjCmd.3 Tcl_DeleteCommandFromToken.3 +fi +if test -r Notifier.3; then + rm -f Tcl_DeleteEventSource.3 + ln Notifier.3 Tcl_DeleteEventSource.3 +fi +if test -r Notifier.3; then + rm -f Tcl_DeleteEvents.3 + ln Notifier.3 Tcl_DeleteEvents.3 +fi +if test -r Exit.3; then + rm -f Tcl_DeleteExitHandler.3 + ln Exit.3 Tcl_DeleteExitHandler.3 +fi +if test -r CrtFileHdlr.3; then + rm -f Tcl_DeleteFileHandler.3 + ln CrtFileHdlr.3 Tcl_DeleteFileHandler.3 +fi +if test -r Hash.3; then + rm -f Tcl_DeleteHashEntry.3 + ln Hash.3 Tcl_DeleteHashEntry.3 +fi +if test -r Hash.3; then + rm -f Tcl_DeleteHashTable.3 + ln Hash.3 Tcl_DeleteHashTable.3 +fi +if test -r CrtInterp.3; then + rm -f Tcl_DeleteInterp.3 + ln CrtInterp.3 Tcl_DeleteInterp.3 +fi +if test -r CrtTimerHdlr.3; then + rm -f Tcl_DeleteTimerHandler.3 + ln CrtTimerHdlr.3 Tcl_DeleteTimerHandler.3 +fi +if test -r CrtTrace.3; then + rm -f Tcl_DeleteTrace.3 + ln CrtTrace.3 Tcl_DeleteTrace.3 +fi +if test -r DetachPids.3; then + rm -f Tcl_DetachPids.3 + ln DetachPids.3 Tcl_DetachPids.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 + ln DoWhenIdle.3 Tcl_DoWhenIdle.3 +fi +if test -r CallDel.3; then + rm -f Tcl_DontCallWhenDeleted.3 + ln CallDel.3 Tcl_DontCallWhenDeleted.3 +fi +if test -r Object.3; then + rm -f Tcl_DuplicateObj.3 + ln Object.3 Tcl_DuplicateObj.3 +fi +if test -r OpenFileChnl.3; then + rm -f Tcl_Eof.3 + ln OpenFileChnl.3 Tcl_Eof.3 +fi +if test -r Eval.3; then + rm -f Tcl_Eval.3 + ln Eval.3 Tcl_Eval.3 +fi +if test -r Eval.3; then + rm -f Tcl_EvalFile.3 + ln Eval.3 Tcl_EvalFile.3 +fi +if test -r EvalObj.3; then + rm -f Tcl_EvalObj.3 + ln EvalObj.3 Tcl_EvalObj.3 +fi +if test -r Preserve.3; then + rm -f Tcl_EventuallyFree.3 + ln Preserve.3 Tcl_EventuallyFree.3 +fi +if test -r Exit.3; then + rm -f Tcl_Exit.3 + ln Exit.3 Tcl_Exit.3 +fi +if test -r CrtSlave.3; then + rm -f Tcl_ExposeCommand.3 + ln CrtSlave.3 Tcl_ExposeCommand.3 +fi +if test -r ExprLong.3; then + rm -f Tcl_ExprBoolean.3 + ln ExprLong.3 Tcl_ExprBoolean.3 +fi +if test -r ExprLongObj.3; then + rm -f Tcl_ExprBooleanObj.3 + ln ExprLongObj.3 Tcl_ExprBooleanObj.3 +fi +if test -r ExprLong.3; then + rm -f Tcl_ExprDouble.3 + ln ExprLong.3 Tcl_ExprDouble.3 +fi +if test -r ExprLongObj.3; then + rm -f Tcl_ExprDoubleObj.3 + ln ExprLongObj.3 Tcl_ExprDoubleObj.3 +fi +if test -r ExprLong.3; then + rm -f Tcl_ExprLong.3 + ln ExprLong.3 Tcl_ExprLong.3 +fi +if test -r ExprLongObj.3; then + rm -f Tcl_ExprLongObj.3 + ln ExprLongObj.3 Tcl_ExprLongObj.3 +fi +if test -r ExprLongObj.3; then + rm -f Tcl_ExprObj.3 + ln ExprLongObj.3 Tcl_ExprObj.3 +fi +if test -r ExprLong.3; then + rm -f Tcl_ExprString.3 + ln ExprLong.3 Tcl_ExprString.3 +fi +if test -r Exit.3; then + rm -f Tcl_Finalize.3 + ln Exit.3 Tcl_Finalize.3 +fi +if test -r FindExec.3; then + rm -f Tcl_FindExecutable.3 + ln FindExec.3 Tcl_FindExecutable.3 +fi +if test -r Hash.3; then + rm -f Tcl_FindHashEntry.3 + ln Hash.3 Tcl_FindHashEntry.3 +fi +if test -r Hash.3; then + rm -f Tcl_FirstHashEntry.3 + ln Hash.3 Tcl_FirstHashEntry.3 +fi +if test -r OpenFileChnl.3; then + rm -f Tcl_Flush.3 + ln OpenFileChnl.3 Tcl_Flush.3 +fi +if test -r Alloc.3; then + rm -f Tcl_Free.3 + ln Alloc.3 Tcl_Free.3 +fi +if test -r CrtSlave.3; then + rm -f Tcl_GetAlias.3 + ln CrtSlave.3 Tcl_GetAlias.3 +fi +if test -r CrtSlave.3; then + rm -f Tcl_GetAliasObj.3 + ln CrtSlave.3 Tcl_GetAliasObj.3 +fi +if test -r AssocData.3; then + rm -f Tcl_GetAssocData.3 + ln AssocData.3 Tcl_GetAssocData.3 +fi +if test -r GetInt.3; then + rm -f Tcl_GetBoolean.3 + ln GetInt.3 Tcl_GetBoolean.3 +fi +if test -r BoolObj.3; then + rm -f Tcl_GetBooleanFromObj.3 + ln BoolObj.3 Tcl_GetBooleanFromObj.3 +fi +if test -r OpenFileChnl.3; then + rm -f Tcl_GetChannel.3 + ln OpenFileChnl.3 Tcl_GetChannel.3 +fi +if test -r CrtChannel.3; then + rm -f Tcl_GetChannelBufferSize.3 + ln CrtChannel.3 Tcl_GetChannelBufferSize.3 +fi +if test -r CrtChannel.3; then + rm -f Tcl_GetChannelHandle.3 + ln CrtChannel.3 Tcl_GetChannelHandle.3 +fi +if test -r CrtChannel.3; then + rm -f Tcl_GetChannelInstanceData.3 + ln CrtChannel.3 Tcl_GetChannelInstanceData.3 +fi +if test -r CrtChannel.3; then + rm -f Tcl_GetChannelMode.3 + ln CrtChannel.3 Tcl_GetChannelMode.3 +fi +if test -r CrtChannel.3; then + rm -f Tcl_GetChannelName.3 + ln CrtChannel.3 Tcl_GetChannelName.3 +fi +if test -r OpenFileChnl.3; then + rm -f Tcl_GetChannelOption.3 + ln OpenFileChnl.3 Tcl_GetChannelOption.3 +fi +if test -r CrtChannel.3; then + rm -f Tcl_GetChannelType.3 + ln CrtChannel.3 Tcl_GetChannelType.3 +fi +if test -r CrtObjCmd.3; then + rm -f Tcl_GetCommandInfo.3 + ln CrtObjCmd.3 Tcl_GetCommandInfo.3 +fi +if test -r CrtObjCmd.3; then + rm -f Tcl_GetCommandName.3 + ln CrtObjCmd.3 Tcl_GetCommandName.3 +fi +if test -r GetInt.3; then + rm -f Tcl_GetDouble.3 + ln GetInt.3 Tcl_GetDouble.3 +fi +if test -r DoubleObj.3; then + rm -f Tcl_GetDoubleFromObj.3 + ln DoubleObj.3 Tcl_GetDoubleFromObj.3 +fi +if test -r SetErrno.3; then + rm -f Tcl_GetErrno.3 + ln SetErrno.3 Tcl_GetErrno.3 +fi +if test -r Hash.3; then + rm -f Tcl_GetHashKey.3 + ln Hash.3 Tcl_GetHashKey.3 +fi +if test -r Hash.3; then + rm -f Tcl_GetHashValue.3 + ln Hash.3 Tcl_GetHashValue.3 +fi +if test -r GetIndex.3; then + rm -f Tcl_GetIndexFromObj.3 + ln GetIndex.3 Tcl_GetIndexFromObj.3 +fi +if test -r GetInt.3; then + rm -f Tcl_GetInt.3 + ln GetInt.3 Tcl_GetInt.3 +fi +if test -r IntObj.3; then + rm -f Tcl_GetIntFromObj.3 + ln IntObj.3 Tcl_GetIntFromObj.3 +fi +if test -r CrtSlave.3; then + rm -f Tcl_GetInterpPath.3 + ln CrtSlave.3 Tcl_GetInterpPath.3 +fi +if test -r IntObj.3; then + rm -f Tcl_GetLongFromObj.3 + ln IntObj.3 Tcl_GetLongFromObj.3 +fi +if test -r CrtSlave.3; then + rm -f Tcl_GetMaster.3 + ln CrtSlave.3 Tcl_GetMaster.3 +fi +if test -r SetResult.3; then + rm -f Tcl_GetObjResult.3 + ln SetResult.3 Tcl_GetObjResult.3 +fi +if test -r ObjectType.3; then + rm -f Tcl_GetObjType.3 + ln ObjectType.3 Tcl_GetObjType.3 +fi +if test -r GetOpnFl.3; then + rm -f Tcl_GetOpenFile.3 + ln GetOpnFl.3 Tcl_GetOpenFile.3 +fi +if test -r SplitPath.3; then + rm -f Tcl_GetPathType.3 + ln SplitPath.3 Tcl_GetPathType.3 +fi +if test -r Notifier.3; then + rm -f Tcl_GetServiceMode.3 + ln Notifier.3 Tcl_GetServiceMode.3 +fi +if test -r CrtSlave.3; then + rm -f Tcl_GetSlave.3 + ln CrtSlave.3 Tcl_GetSlave.3 +fi +if test -r GetStdChan.3; then + rm -f Tcl_GetStdChannel.3 + ln GetStdChan.3 Tcl_GetStdChannel.3 +fi +if test -r StringObj.3; then + rm -f Tcl_GetStringFromObj.3 + ln StringObj.3 Tcl_GetStringFromObj.3 +fi +if test -r SetResult.3; then + rm -f Tcl_GetStringResult.3 + ln SetResult.3 Tcl_GetStringResult.3 +fi +if test -r SetVar.3; then + rm -f Tcl_GetVar.3 + ln SetVar.3 Tcl_GetVar.3 +fi +if test -r SetVar.3; then + rm -f Tcl_GetVar2.3 + ln SetVar.3 Tcl_GetVar2.3 +fi +if test -r OpenFileChnl.3; then + rm -f Tcl_Gets.3 + ln OpenFileChnl.3 Tcl_Gets.3 +fi +if test -r Eval.3; then + rm -f Tcl_GlobalEval.3 + ln Eval.3 Tcl_GlobalEval.3 +fi +if test -r EvalObj.3; then + rm -f Tcl_GlobalEvalObj.3 + ln EvalObj.3 Tcl_GlobalEvalObj.3 +fi +if test -r Hash.3; then + rm -f Tcl_HashStats.3 + ln Hash.3 Tcl_HashStats.3 +fi +if test -r CrtSlave.3; then + rm -f Tcl_HideCommand.3 + ln CrtSlave.3 Tcl_HideCommand.3 +fi +if test -r Object.3; then + rm -f Tcl_IncrRefCount.3 + ln Object.3 Tcl_IncrRefCount.3 +fi +if test -r Hash.3; then + rm -f Tcl_InitHashTable.3 + ln Hash.3 Tcl_InitHashTable.3 +fi +if test -r OpenFileChnl.3; then + rm -f Tcl_InputBlocked.3 + ln OpenFileChnl.3 Tcl_InputBlocked.3 +fi +if test -r OpenFileChnl.3; then + rm -f Tcl_InputBuffered.3 + ln OpenFileChnl.3 Tcl_InputBuffered.3 +fi +if test -r Interp.3; then + rm -f Tcl_Interp.3 + ln Interp.3 Tcl_Interp.3 +fi +if test -r CrtInterp.3; then + rm -f Tcl_InterpDeleted.3 + ln CrtInterp.3 Tcl_InterpDeleted.3 +fi +if test -r CrtSlave.3; then + rm -f Tcl_IsSafe.3 + ln CrtSlave.3 Tcl_IsSafe.3 +fi +if test -r Object.3; then + rm -f Tcl_IsShared.3 + ln Object.3 Tcl_IsShared.3 +fi +if test -r SplitPath.3; then + rm -f Tcl_JoinPath.3 + ln SplitPath.3 Tcl_JoinPath.3 +fi +if test -r LinkVar.3; then + rm -f Tcl_LinkVar.3 + ln LinkVar.3 Tcl_LinkVar.3 +fi +if test -r ListObj.3; then + rm -f Tcl_ListObjAppendElement.3 + ln ListObj.3 Tcl_ListObjAppendElement.3 +fi +if test -r ListObj.3; then + rm -f Tcl_ListObjAppendList.3 + ln ListObj.3 Tcl_ListObjAppendList.3 +fi +if test -r ListObj.3; then + rm -f Tcl_ListObjGetElements.3 + ln ListObj.3 Tcl_ListObjGetElements.3 +fi +if test -r ListObj.3; then + rm -f Tcl_ListObjIndex.3 + ln ListObj.3 Tcl_ListObjIndex.3 +fi +if test -r ListObj.3; then + rm -f Tcl_ListObjLength.3 + ln ListObj.3 Tcl_ListObjLength.3 +fi +if test -r ListObj.3; then + rm -f Tcl_ListObjReplace.3 + ln ListObj.3 Tcl_ListObjReplace.3 +fi +if test -r OpenFileChnl.3; then + rm -f Tcl_MakeFileChannel.3 + ln OpenFileChnl.3 Tcl_MakeFileChannel.3 +fi +if test -r CrtSlave.3; then + rm -f Tcl_MakeSafe.3 + ln CrtSlave.3 Tcl_MakeSafe.3 +fi +if test -r OpenTcp.3; then + rm -f Tcl_MakeTcpClientChannel.3 + ln OpenTcp.3 Tcl_MakeTcpClientChannel.3 +fi +if test -r SplitList.3; then + rm -f Tcl_Merge.3 + ln SplitList.3 Tcl_Merge.3 +fi +if test -r BoolObj.3; then + rm -f Tcl_NewBooleanObj.3 + ln BoolObj.3 Tcl_NewBooleanObj.3 +fi +if test -r DoubleObj.3; then + rm -f Tcl_NewDoubleObj.3 + ln DoubleObj.3 Tcl_NewDoubleObj.3 +fi +if test -r IntObj.3; then + rm -f Tcl_NewIntObj.3 + ln IntObj.3 Tcl_NewIntObj.3 +fi +if test -r ListObj.3; then + rm -f Tcl_NewListObj.3 + ln ListObj.3 Tcl_NewListObj.3 +fi +if test -r IntObj.3; then + rm -f Tcl_NewLongObj.3 + ln IntObj.3 Tcl_NewLongObj.3 +fi +if test -r Object.3; then + rm -f Tcl_NewObj.3 + ln Object.3 Tcl_NewObj.3 +fi +if test -r StringObj.3; then + rm -f Tcl_NewStringObj.3 + ln StringObj.3 Tcl_NewStringObj.3 +fi +if test -r Hash.3; then + rm -f Tcl_NextHashEntry.3 + ln Hash.3 Tcl_NextHashEntry.3 +fi +if test -r CrtChannel.3; then + rm -f Tcl_NotifyChannel.3 + ln CrtChannel.3 Tcl_NotifyChannel.3 +fi +if test -r ObjSetVar.3; then + rm -f Tcl_ObjGetVar2.3 + ln ObjSetVar.3 Tcl_ObjGetVar2.3 +fi +if test -r ObjSetVar.3; then + rm -f Tcl_ObjSetVar2.3 + ln ObjSetVar.3 Tcl_ObjSetVar2.3 +fi +if test -r OpenFileChnl.3; then + rm -f Tcl_OpenCommandChannel.3 + ln OpenFileChnl.3 Tcl_OpenCommandChannel.3 +fi +if test -r OpenFileChnl.3; then + rm -f Tcl_OpenFileChannel.3 + ln OpenFileChnl.3 Tcl_OpenFileChannel.3 +fi +if test -r OpenTcp.3; then + rm -f Tcl_OpenTcpClient.3 + ln OpenTcp.3 Tcl_OpenTcpClient.3 +fi +if test -r OpenTcp.3; then + rm -f Tcl_OpenTcpServer.3 + ln OpenTcp.3 Tcl_OpenTcpServer.3 +fi +if test -r PkgRequire.3; then + rm -f Tcl_PkgProvide.3 + ln PkgRequire.3 Tcl_PkgProvide.3 +fi +if test -r PkgRequire.3; then + rm -f Tcl_PkgRequire.3 + ln PkgRequire.3 Tcl_PkgRequire.3 +fi +if test -r AddErrInfo.3; then + rm -f Tcl_PosixError.3 + ln AddErrInfo.3 Tcl_PosixError.3 +fi +if test -r Preserve.3; then + rm -f Tcl_Preserve.3 + ln Preserve.3 Tcl_Preserve.3 +fi +if test -r PrintDbl.3; then + rm -f Tcl_PrintDouble.3 + ln PrintDbl.3 Tcl_PrintDouble.3 +fi +if test -r Notifier.3; then + rm -f Tcl_QueueEvent.3 + ln Notifier.3 Tcl_QueueEvent.3 +fi +if test -r OpenFileChnl.3; then + rm -f Tcl_Read.3 + ln OpenFileChnl.3 Tcl_Read.3 +fi +if test -r Alloc.3; then + rm -f Tcl_Realloc.3 + ln Alloc.3 Tcl_Realloc.3 +fi +if test -r DetachPids.3; then + rm -f Tcl_ReapDetachedProcs.3 + ln DetachPids.3 Tcl_ReapDetachedProcs.3 +fi +if test -r RecordEval.3; then + rm -f Tcl_RecordAndEval.3 + ln RecordEval.3 Tcl_RecordAndEval.3 +fi +if test -r RecEvalObj.3; then + rm -f Tcl_RecordAndEvalObj.3 + ln RecEvalObj.3 Tcl_RecordAndEvalObj.3 +fi +if test -r RegExp.3; then + rm -f Tcl_RegExpCompile.3 + ln RegExp.3 Tcl_RegExpCompile.3 +fi +if test -r RegExp.3; then + rm -f Tcl_RegExpExec.3 + ln RegExp.3 Tcl_RegExpExec.3 +fi +if test -r RegExp.3; then + rm -f Tcl_RegExpMatch.3 + ln RegExp.3 Tcl_RegExpMatch.3 +fi +if test -r RegExp.3; then + rm -f Tcl_RegExpRange.3 + ln RegExp.3 Tcl_RegExpRange.3 +fi +if test -r OpenFileChnl.3; then + rm -f Tcl_RegisterChannel.3 + ln OpenFileChnl.3 Tcl_RegisterChannel.3 +fi +if test -r ObjectType.3; then + rm -f Tcl_RegisterObjType.3 + ln ObjectType.3 Tcl_RegisterObjType.3 +fi +if test -r Preserve.3; then + rm -f Tcl_Release.3 + ln Preserve.3 Tcl_Release.3 +fi +if test -r SetResult.3; then + rm -f Tcl_ResetResult.3 + ln SetResult.3 Tcl_ResetResult.3 +fi +if test -r SplitList.3; then + rm -f Tcl_ScanElement.3 + ln SplitList.3 Tcl_ScanElement.3 +fi +if test -r OpenFileChnl.3; then + rm -f Tcl_Seek.3 + ln OpenFileChnl.3 Tcl_Seek.3 +fi +if test -r Notifier.3; then + rm -f Tcl_ServiceAll.3 + ln Notifier.3 Tcl_ServiceAll.3 +fi +if test -r Notifier.3; then + rm -f Tcl_ServiceEvent.3 + ln Notifier.3 Tcl_ServiceEvent.3 +fi +if test -r AssocData.3; then + rm -f Tcl_SetAssocData.3 + ln AssocData.3 Tcl_SetAssocData.3 +fi +if test -r BoolObj.3; then + rm -f Tcl_SetBooleanObj.3 + ln BoolObj.3 Tcl_SetBooleanObj.3 +fi +if test -r CrtChannel.3; then + rm -f Tcl_SetChannelBufferSize.3 + ln CrtChannel.3 Tcl_SetChannelBufferSize.3 +fi +if test -r OpenFileChnl.3; then + rm -f Tcl_SetChannelOption.3 + ln OpenFileChnl.3 Tcl_SetChannelOption.3 +fi +if test -r CrtObjCmd.3; then + rm -f Tcl_SetCommandInfo.3 + ln CrtObjCmd.3 Tcl_SetCommandInfo.3 +fi +if test -r CrtChannel.3; then + rm -f Tcl_SetDefaultTranslation.3 + ln CrtChannel.3 Tcl_SetDefaultTranslation.3 +fi +if test -r DoubleObj.3; then + rm -f Tcl_SetDoubleObj.3 + ln DoubleObj.3 Tcl_SetDoubleObj.3 +fi +if test -r SetErrno.3; then + rm -f Tcl_SetErrno.3 + ln SetErrno.3 Tcl_SetErrno.3 +fi +if test -r AddErrInfo.3; then + rm -f Tcl_SetErrorCode.3 + ln AddErrInfo.3 Tcl_SetErrorCode.3 +fi +if test -r Hash.3; then + rm -f Tcl_SetHashValue.3 + ln Hash.3 Tcl_SetHashValue.3 +fi +if test -r IntObj.3; then + rm -f Tcl_SetIntObj.3 + ln IntObj.3 Tcl_SetIntObj.3 +fi +if test -r ListObj.3; then + rm -f Tcl_SetListObj.3 + ln ListObj.3 Tcl_SetListObj.3 +fi +if test -r IntObj.3; then + rm -f Tcl_SetLongObj.3 + ln IntObj.3 Tcl_SetLongObj.3 +fi +if test -r Notifier.3; then + rm -f Tcl_SetMaxBlockTime.3 + ln Notifier.3 Tcl_SetMaxBlockTime.3 +fi +if test -r StringObj.3; then + rm -f Tcl_SetObjLength.3 + ln StringObj.3 Tcl_SetObjLength.3 +fi +if test -r SetResult.3; then + rm -f Tcl_SetObjResult.3 + ln SetResult.3 Tcl_SetObjResult.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_SetResult.3 + ln SetResult.3 Tcl_SetResult.3 +fi +if test -r Notifier.3; then + rm -f Tcl_SetServiceMode.3 + ln Notifier.3 Tcl_SetServiceMode.3 +fi +if test -r GetStdChan.3; then + rm -f Tcl_SetStdChannel.3 + ln GetStdChan.3 Tcl_SetStdChannel.3 +fi +if test -r StringObj.3; then + rm -f Tcl_SetStringObj.3 + ln StringObj.3 Tcl_SetStringObj.3 +fi +if test -r Notifier.3; then + rm -f Tcl_SetTimer.3 + ln Notifier.3 Tcl_SetTimer.3 +fi +if test -r SetVar.3; then + rm -f Tcl_SetVar.3 + ln SetVar.3 Tcl_SetVar.3 +fi +if test -r SetVar.3; then + rm -f Tcl_SetVar2.3 + ln SetVar.3 Tcl_SetVar2.3 +fi +if test -r Sleep.3; then + rm -f Tcl_Sleep.3 + ln Sleep.3 Tcl_Sleep.3 +fi +if test -r SplitList.3; then + rm -f Tcl_SplitList.3 + ln SplitList.3 Tcl_SplitList.3 +fi +if test -r SplitPath.3; then + rm -f Tcl_SplitPath.3 + ln SplitPath.3 Tcl_SplitPath.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 + ln StrMatch.3 Tcl_StringMatch.3 +fi +if test -r OpenFileChnl.3; then + rm -f Tcl_Tell.3 + ln OpenFileChnl.3 Tcl_Tell.3 +fi +if test -r TraceVar.3; then + rm -f Tcl_TraceVar.3 + ln TraceVar.3 Tcl_TraceVar.3 +fi +if test -r TraceVar.3; then + rm -f Tcl_TraceVar2.3 + ln TraceVar.3 Tcl_TraceVar2.3 +fi +if test -r Translate.3; then + rm -f Tcl_TranslateFileName.3 + ln Translate.3 Tcl_TranslateFileName.3 +fi +if test -r LinkVar.3; then + rm -f Tcl_UnlinkVar.3 + ln LinkVar.3 Tcl_UnlinkVar.3 +fi +if test -r OpenFileChnl.3; then + rm -f Tcl_UnregisterChannel.3 + ln OpenFileChnl.3 Tcl_UnregisterChannel.3 +fi +if test -r SetVar.3; then + rm -f Tcl_UnsetVar.3 + ln SetVar.3 Tcl_UnsetVar.3 +fi +if test -r SetVar.3; then + rm -f Tcl_UnsetVar2.3 + ln SetVar.3 Tcl_UnsetVar2.3 +fi +if test -r TraceVar.3; then + rm -f Tcl_UntraceVar.3 + ln TraceVar.3 Tcl_UntraceVar.3 +fi +if test -r TraceVar.3; then + rm -f Tcl_UntraceVar2.3 + ln TraceVar.3 Tcl_UntraceVar2.3 +fi +if test -r UpVar.3; then + rm -f Tcl_UpVar.3 + ln UpVar.3 Tcl_UpVar.3 +fi +if test -r UpVar.3; then + rm -f Tcl_UpVar2.3 + ln UpVar.3 Tcl_UpVar2.3 +fi +if test -r LinkVar.3; then + rm -f Tcl_UpdateLinkedVar.3 + ln LinkVar.3 Tcl_UpdateLinkedVar.3 +fi +if test -r Eval.3; then + rm -f Tcl_VarEval.3 + ln Eval.3 Tcl_VarEval.3 +fi +if test -r TraceVar.3; then + rm -f Tcl_VarTraceInfo.3 + ln TraceVar.3 Tcl_VarTraceInfo.3 +fi +if test -r TraceVar.3; then + rm -f Tcl_VarTraceInfo2.3 + ln TraceVar.3 Tcl_VarTraceInfo2.3 +fi +if test -r Notifier.3; then + rm -f Tcl_WaitForEvent.3 + ln Notifier.3 Tcl_WaitForEvent.3 +fi +if test -r OpenFileChnl.3; then + rm -f Tcl_Write.3 + ln OpenFileChnl.3 Tcl_Write.3 +fi +if test -r WrongNumArgs.3; then + rm -f Tcl_WrongNumArgs.3 + ln WrongNumArgs.3 Tcl_WrongNumArgs.3 +fi +if test -r pkgMkIndex.n; then + rm -f pkg_mkIndex.n + ln pkgMkIndex.n pkg_mkIndex.n +fi +exit 0 diff --git a/unix/porting.notes b/unix/porting.notes new file mode 100644 index 0000000..2d0a403 --- /dev/null +++ b/unix/porting.notes @@ -0,0 +1,412 @@ +This file contains a collection of notes that various people have +provided about porting Tcl to various machines and operating systems. +I don't have personal access to any of these machines, so I make +no guarantees that the notes are correct, complete, or up-to-date. +If you see the word "I" in any explanations, it refers to the person +who contributed the information, not to me; this means that I +probably can't answer any questions about any of this stuff. In +some cases, a person has volunteered to act as a contact point for +questions about porting Tcl to a particular machine; in these +cases the person's name and e-mail address are listed. I'm +interested in getting new porting information to add to the file; +please mail updates to "john.ousterhout@eng.sun.com". + +This file reflects information provided for Tcl 7.4 and later releases (8.x). +If there is no information for your configuration in this file, check +the file "porting.old" too; it contains information that was +submitted for Tcl 7.3 and earlier releases, and some of that information +may still be valid. + +A new porting database has recently become available on the Web at +the following URL: + http://www.sunlabs.com/cgi-bin/tcl/info.8.0 +This page provides information about the platforms on which Tcl and +and Tk 8.0 have been compiled and what changes were needed to get Tcl +and Tk to compile. You can also add new entries to that database +when you install Tcl and Tk on a new platform. The Web database is +likely to be more up-to-date than this file. + +sccsid = SCCS: @(#) porting.notes 1.20 97/11/03 09:43:40 + +-------------------------------------------- +Solaris, various versions +-------------------------------------------- + +1. If typing "make test" results in an error message saying that +there are no "*.test" files, or you get lots of globbing errors, +it's probably because your system doesn't have cc installed and +you used gcc. In order for this to work, you have to set your +CC environment variable to gcc and your CPP environment variable +to "gcc -E" before running the configure script. + +2. Make sure that /usr/ucb is not in your PATH or LD_LIBRARY_PATH +environment variables; this will cause confusion between the new +Solaris libraries and older UCB versions (Tcl will expect one version +and get another). + +3. There have been several reports of problems with the "glob" command. +So far these reports have all been for older versions of Tcl, but +if you run into problems, edit the Makefile after "configure" is +run and add "-DNO_DIRENT_H=1" to the definitions of DEFS. Do this +before compiling. + +-------------------------------------------- +SunOS 4 and potentially other OSes +-------------------------------------------- + +On systems where both getcwd(3) and getwd(3) exist, check the man +page and if getcwd, like on SunOS 4, uses popen to pwd(1) +add -DUSEGETWD to the flags CFLAGS so getwd will be used instead. + +That is, change the CFLAGS = -O line so it reads +CFLAGS = -O -DUSEGETWD + +-------------------------------------------- +Linux, ELF, various versions/distributions +-------------------------------------------- + +If ./configure --enable-shared complains it can not do a shared +library you might have to make the following symbolic link: +ln -s /lib/libdl.so.1 /lib/libdl.so +then remove config.cache and re run configure. + +-------------------------------------------- +Pyramid DC/OSx SVr4, DC/OSx version 94c079 +-------------------------------------------- + +Tcl seems to dump core in cmdinfo.test when compiled with the +optimiser turned on in TclEval which calls 'free'. To get around +this, turn the optimiser off. + +-------------------------------------------- +SGI machines, IRIX 5.2, 5.3, IRIX64 6.0.1 +-------------------------------------------- + +1. If you compile with gcc-2.6.3 under some versions of IRIX (e.g. + 4.0.5), DBL_MAX is defined too large for gcc and Tcl complains + about all floating-point values being too large to represent. + If this happens, redefining DBL_MAX to 9.99e299. + +2. Add "-D_BSD_TIME" to CFLAGS in Makefile. This avoids type conflicts +in the prototype for the gettimeofday procedure. + +2. If you're running under Irix 6.x and tclsh dumps core, try +removing -O from the CFLAGS in Makefile and recompiling; compiler +optimizations seem to cause problems on some machines. + +-------------------------------------------- +IBM RTs, AOS +-------------------------------------------- + +1. Steal fmod from 4.4BSD +2. Add a #define to tclExpr such that: +extern double fmod(); +is defined conditionally on ibm032 + +-------------------------------------------- +QNX 4.22 +-------------------------------------------- + +tclPort.h + - commented out 2 lines containing #include <sys/param.h> + +tcl.h + - changed #define VARARGS () + - to #ifndef __QNX__ + #define VARARGS () + #else + #define VARARGS (void *, ...) + #endif + +-------------------------------------------- +Interactive UNIX +-------------------------------------------- + +Add the switch -Xp to LIBS in Makefile; otherwise strftime will not +be found when linking. + +-------------------------------------------- +Motorola SVR4 V4.2 (m88k) +-------------------------------------------- + +For Motorola Unix R40V4.2 (m88k architechure), use /usr/ucb/cc instead of +/usr/bin/cc. Otherwise, the compile will fail because of conflicts over +the gettimeofday() call. + +Also, -DNO_DIRENT_H=1 is required for the "glob" command to work. + +-------------------------------------------- +NeXTSTEP 3.x +-------------------------------------------- + +Here's the set of changes I made to make 7.5b3 compile cleanly on +NeXTSTEP3.x. + +Here are a couple lines from unix/Makefile: + +# Added utsname.o, which implements a uname() emulation for NeXTSTEP. +COMPAT_OBJS = getcwd.o strtod.o tmpnam.o utsname.o + +TCL_NAMES=\ + -Dstrtod=tcl_strtod -Dtmpnam=tcl_tmpnam -Dgetcwd=tcl_getcwd \ + -Dpanic=tcl_panic -Dmatherr=tcl_matherr \ + -Duname=tcl_uname -Dutsname=tcl_utsname + +# Added mode_t, pid_t, and O_NONBLOCK definitions. +AC_FLAGS = -DNO_DIRENT_H=1 -DHAVE_UNISTD_H=1 -DHAVE_SYS_TIME_H=1 +-DTIME_WITH_SYS_TIME=1 -DHAVE_TM_ZONE=1 -DHAVE_TM_GMTOFF=1 -DHAVE_TIMEZONE_VAR=1 +-DSTDC_HEADERS=1 -Dmode_t=int -Dpid_t=int -DO_NONBLOCK=O_NDELAY ${TCL_NAMES} + + +Here are diffs for other files. utsname.[hc] are a couple files I added +to compat/ I'm not clear whether that's where they legitimately belong +- I considered stashing them in tclLoadNext.c instead. The tclIO.c +change was a bug, I believe, which I reported on comp.lang.tcl and +has apparently been noted and fixed. The objc_loadModules() change +allows "load" to load object code containing Objective-C code in +addition to plain C code. + +--- +scott hess <shess@winternet.com> (WWW to "http://www.winternet.com/~shess/") +Work: 12550 Portland Avenue South #121, Burnsville, MN 55337 (612)895-1208 + + +diff -rc tcl7.5b3.orig/compat/utsname.c tcl7.5b3/compat/utsname.c +*** tcl7.5b3.orig/compat/utsname.c Tue Apr 2 13:57:23 1996 +--- tcl7.5b3/compat/utsname.c Mon Mar 18 11:05:54 1996 +*************** +*** 0 **** +--- 1,27 ---- ++ /* ++ * utsname.c -- ++ * ++ * This file is an emulation of the POSIX uname() function ++ * under NeXTSTEP 3.x. ++ * ++ */ ++ + ++ #include "utsname.h" ++ #include <mach-o/arch.h> ++ #include <stdio.h> ++ + ++ int uname( struct utsname *name) ++ { ++ const NXArchInfo *arch; ++ if( gethostname( name->nodename, sizeof( name->nodename))==-1) { ++ return -1; ++ } ++ if( (arch=NXGetLocalArchInfo())==NULL) { ++ return -1; ++ } ++ strncpy( name->machine, arch->description, sizeof( name->machine)); ++ strcpy( name->sysname, "NEXTSTEP"); ++ strcpy( name->release, "0"); ++ strcpy( name->version, "3"); ++ return 0; ++ } +diff -rc tcl7.5b3.orig/compat/utsname.h tcl7.5b3/compat/utsname.h +*** tcl7.5b3.orig/compat/utsname.h Tue Apr 2 13:57:26 1996 +--- tcl7.5b3/compat/utsname.h Mon Mar 18 10:34:05 1996 +*************** +*** 0 **** +--- 1,22 ---- ++ /* ++ * utsname.h -- ++ * ++ * This file is an emulation of the POSIX uname() function ++ * under NeXTSTEP. ++ * ++ */ ++ + ++ #ifndef _UTSNAME ++ #define _UTSNAME ++ + ++ struct utsname { ++ char sysname[ 32]; ++ char nodename[ 32]; ++ char release[ 32]; ++ char version[ 32]; ++ char machine[ 32]; ++ }; ++ + ++ extern int uname( struct utsname *name); ++ + ++ #endif /* _UTSNAME */ +diff -rc tcl7.5b3.orig/generic/tclIO.c tcl7.5b3/generic/tclIO.c +*** tcl7.5b3.orig/generic/tclIO.c Fri Mar 8 12:59:53 1996 +--- tcl7.5b3/generic/tclIO.c Mon Mar 18 11:38:57 1996 +*************** +*** 2542,2548 **** + } + result = GetInput(chanPtr); + if (result != 0) { +! if (result == EWOULDBLOCK) { + chanPtr->flags |= CHANNEL_BLOCKED; + return copied; + } +--- 2542,2548 ---- + } + result = GetInput(chanPtr); + if (result != 0) { +! if (result == EAGAIN) { + chanPtr->flags |= CHANNEL_BLOCKED; + return copied; + } +diff -rc tcl7.5b3.orig/unix/tclLoadNext.c tcl7.5b3/unix/tclLoadNext.c +*** tcl7.5b3.orig/unix/tclLoadNext.c Sat Feb 17 16:16:42 1996 +--- tcl7.5b3/unix/tclLoadNext.c Mon Mar 18 10:02:36 1996 +*************** +*** 55,61 **** + 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); +--- 55,61 ---- + char *files[]={fileName,NULL}; + NXStream *errorStream=NXOpenMemory(0,0,NX_READWRITE); + + +! if(objc_loadModules(files,errorStream,NULL,&header,NULL)) { + NXGetMemoryBuffer(errorStream,&data,&len,&maxlen); + Tcl_AppendResult(interp,"couldn't load file \"",fileName,"\": ",data,NULL); + NXCloseMemory(errorStream,NX_FREEBUFFER); +diff -rc tcl7.5b3.orig/unix/tclUnixFile.c tcl7.5b3/unix/tclUnixFile.c +*** tcl7.5b3.orig/unix/tclUnixFile.c Thu Mar 7 18:16:34 1996 +--- tcl7.5b3/unix/tclUnixFile.c Mon Mar 18 11:10:03 1996 +*************** +*** 31,37 **** +--- 31,41 ---- + + + static int executableNameExitHandlerSet = 0; + + ++ #if NeXT ++ #define waitpid( p, s, o) wait4( p, s, o, NULL) ++ #else + extern pid_t waitpid _ANSI_ARGS_((pid_t pid, int *stat_loc, int options)); ++ #endif + + + /* + * Static routines for this file: +diff -rc tcl7.5b3.orig/unix/tclUnixInit.c tcl7.5b3/unix/tclUnixInit.c +*** tcl7.5b3.orig/unix/tclUnixInit.c Sat Feb 17 16:16:39 1996 +--- tcl7.5b3/unix/tclUnixInit.c Mon Mar 18 11:50:28 1996 +*************** +*** 14,20 **** + #include "tclInt.h" + #include "tclPort.h" + #ifndef NO_UNAME +! # include <sys/utsname.h> + #endif + #if defined(__FreeBSD__) + #include <floatingpoint.h> +--- 14,24 ---- + #include "tclInt.h" + #include "tclPort.h" + #ifndef NO_UNAME +! # if NeXT +! # include "../compat/utsname.h" +! # else +! # include <sys/utsname.h> +! # endif + #endif + #if defined(__FreeBSD__) + #include <floatingpoint.h> +diff -rc tcl7.5b3.orig/unix/tclUnixPort.h tcl7.5b3/unix/tclUnixPort.h +*** tcl7.5b3.orig/unix/tclUnixPort.h Thu Mar 7 18:16:31 1996 +--- tcl7.5b3/unix/tclUnixPort.h Mon Mar 18 11:53:14 1996 +*************** +*** 76,82 **** + */ + + + #include <sys/socket.h> /* struct sockaddr, SOCK_STREAM, ... */ +! #include <sys/utsname.h> /* uname system call. */ + #include <netinet/in.h> /* struct in_addr, struct sockaddr_in */ + #include <arpa/inet.h> /* inet_ntoa() */ + #include <netdb.h> /* gethostbyname() */ +--- 76,88 ---- + */ + + + #include <sys/socket.h> /* struct sockaddr, SOCK_STREAM, ... */ +! #ifndef NO_UNAME +! # if NeXT +! # include "../compat/utsname.h" +! # else +! # include <sys/utsname.h> /* uname system call. */ +! # endif +! #endif + #include <netinet/in.h> /* struct in_addr, struct sockaddr_in */ + #include <arpa/inet.h> /* inet_ntoa() */ + #include <netdb.h> /* gethostbyname() */ + +-------------------------------------------- +SCO Unix 3.2.4 (ODT 3.0) +-------------------------------------------- + +The macro va_start in /usr/include/stdarg.h is incorrectly terminated by +a semi-colon. This causes compile of generic/tclBasic.c to fail. The +best solution is to edit the definition of va_start to remove the `;'. +This will fix this file for anything you want to compile. If you don't have +permission to edit /usr/include/stdarg.h in place, copy it to the tcl unix +directory and change it there. + +Contact me directly if you have problems on SCO systems. +Mark Diekhans <markd@grizzly.com> + +-------------------------------------------- +SCO Unix 3.2.5 (ODT 5.0) +-------------------------------------------- + +Expect failures from socket tests 2.9 and 3.1. + +Contact me directly if you have problems on SCO systems. +Mark Diekhans <markd@grizzly.com> + +-------------------------------------------- +Linux 1.2.13 (gcc 2.7.0, libc.so.5.0.9) +-------------------------------------------- + +Symptoms: + +* Some extensions could not be loaded dynamically, most + prominently Blt 2.0 + + The given error message essentially said: + Could not resolve symbol '__eprintf'. + + (This procedure is used by the macro 'assert') + +Cause + +* '__eprintf' is defined in 'libgcc.a', not 'libc.so.x.y'. + It is therefore impossible to load it dynamically. + +* Neither tcl nor tk make use of 'assert', thereby + preventing a static linkage. + +Workaround + +* I included <assert.h> in 'tclAppInit.c' / 'tkAppInit.c' + and then executed 'assert (argc)' just before the call + to Tcl_Main / Tk_Main. + + This forced the static linkage of '__eprintf' and + everything went fine from then on. + + (Something like 'assert (1)', 'assert (a==a)' is not + sufficient, it will be optimized away). + diff --git a/unix/porting.old b/unix/porting.old new file mode 100644 index 0000000..e312de0 --- /dev/null +++ b/unix/porting.old @@ -0,0 +1,384 @@ +This is an old version of the file "porting.notes". It contains +porting information that people submitted for Tcl releases numbered +7.3 and earlier. You may find information in this file useful if +there is no information available for your machine in the current +version of "porting.notes". + +I don't have personal access to any of these machines, so I make +no guarantees that the notes are correct, complete, or up-to-date. +If you see the word "I" in any explanations, it refers to the person +who contributed the information, not to me; this means that I +probably can't answer any questions about any of this stuff. In +some cases, a person has volunteered to act as a contact point for +questions about porting Tcl to a particular machine; in these +cases the person's name and e-mail address are listed. + +sccsid = SCCS: @(#) porting.old 1.3 96/02/16 08:56:07 + +--------------------------------------------- +Cray machines running UNICOS: +Contact: John Freeman (jlf@cray.com) +--------------------------------------------- + +1. There is an error in the strstr function in UNICOS such that if the +string to be searched is empty (""), the search will continue past the +end of the string. Because of this, the history substitution loop +will sometimes run past the end of its target string and trash +malloc's free list, resulting in a core dump some time later. (As you +can probably guess, this took a while to diagnose.) I've submitted a +problem report to the C library maintainers, but in the meantime here +is a workaround. + +----------------------------------------------------------------- +diff -c1 -r1.1 tclHistory.c +*** 1.1 1991/11/12 16:01:58 +--- tclHistory.c 1991/11/12 16:14:22 +*************** +*** 23,24 **** +--- 23,29 ---- + #include "tclInt.h" ++ ++ #ifdef _CRAY ++ /* There is a bug in strstr in UNICOS; this works around it. */ ++ #define strstr(s1,s2) ((s1)?(*(s1)?strstr((s1),(s2)):0):0) ++ #endif _CRAY + +--------------------------------------------- +MIPS systems runing EP/IX: +--------------------------------------------- + +1. Need to add a line "#include <bsd/sys/time.h>" in tclUnix.h. + +2. Need to add "-lbsd" into the line that makes tclTest: + + ${CC} ${CFLAGS} tclTest.o libtcl.a -lbsd -o tclTest + +--------------------------------------------- +IBM RS/6000 systems running AIX: +--------------------------------------------- + +1. The system version of strtoul is buggy, at least under some +versions of AIX. If the expression tests fail, try forcing Tcl +to use its own version of strtoul instead of the system version. +To do this, first copy strtoul.c from the compat subdirectory up +to the main Tcl directory. Then modify the Makefile so that +the definition for COMPAT_OBJS includes "strtoul.o". Note: the +"config" script should now detect the buggy strtoul and substitute +Tcl's version automatically. + +2. You may have to comment out the declaration of open in tclUnix.h. + +3. You may need to add "-D_BSD -lbsd" to the CFLAGS definition. This +causes the system include files to look like BSD include files and +causes C library routines to act like bsd library routines. Without +this, the system may choke on "struct wait". + +--------------------------------------------- +AT&T 4.03 OS: +--------------------------------------------- + +Machine: i386/33Mhz i387 32k Cache 16MByte +OS: AT&T SYSV Release 4 Version 3 +X: X11R5 fixlevel 9 +Xserver: X386 1.2 + +1. Change the Tk Makefile as follows: +XLIB = -lX11 + should be changed to: +XLIB = -lX11 -lsocket -lnsl + +------------------------------------------------------- +Silicon Graphics systems: +------------------------------------------------------- + +1. Change the CC variable in the Makefile to: + +CC = cc -xansi -D__STDC__ -signed + +2. In Irix releases 4.0.1 or earlier the C compiler has a buggy optimizer. + If Tcl fails its test suite or generates inexplicable errors, + compile tclVar.c with -O0 instead of -O. + +3. For IRIX 5.1 or later, comments 1 and 2 are no longer relevant, +but you must add -D_BSD_SIGNALS to CFLAGS to get the proper signal +routines. + +4. Add a "-lsun" switch in the targets for tclsh and tcltest, +just before ${MATH_LIBS}. + +5. Rumor has it that you also need to add the "-lmalloc" library switch +in the targets for tclsh and tcltest. + +6. In IRIX 5.2 you'll have to modify Makefile to fix the following problems: + - The "-c" option is illegal with this version of install, but + the "-F" switch is needed instead. Change this in the "INSTALL =" + definition line. + - The order of file and directory have to be changed in all the + invocations of INSTALL_DATA or INSTALL_PROGRAM. + +--------------------------------------------- +NeXT machines running NeXTStep 3.1: +--------------------------------------------- + +1. Run configure with predefined CPP: + CPP='cc -E' ./configure + (If your shell is [t]csh, do a "setenv CPP 'cc -E' ") + +2. Edit Makefile: + -add tmpnam.o to COMPAT_OBJS: + COMPAT_OBJS = getcwd.o waitpid.o strtod.o tmpnam.o + -add the following to AC_FLAGS: + -Dstrtod=tcl_strtod + +3. Edit compat/tmpnam.c and replace "/usr/tmp" with "/tmp" + +After this, tcl7.0 will be build fine on NeXT (ignore linker warning) +and run all the tests. There are some formatting problems in printf() or +scanf() which come from NeXT's lacking POSIX conformance. Ignore those +errors, they don't matter much. + +4. Additional information that may apply to NeXTStep 3.2 only: + + The problem on NEXTSTEP 3.2 is that the configure script makes some + bad assumptions about the uid_t and gid_t types. Actually, the may + have been valid for NEXTSTEP 3.0, or it may be NEXTSTEP's rudimentary + attempt at POSIX support under 3.2, but no matter what the reason, the + configure script sets up the Makefile with CFLAGS '-Duid_t=int' and + '-Dgid_t=int', which are, unfortunately, incorrect, since they shoudl + actually be (I think) unsigned shorts. This causes problems when the + 'stat' structure is included, since it throws off the field offsets + from what the 'fstat' function thinks they should be. + + Anyway, the quick fix is to run configure and then edit the Makefile + to remove the uid_t and gid_t defines. This will allow tcl and Tk to + compile and run. There are some other problems on NEXTSTEP, + specifically with %g in the printf family of functions, but making the + uid_t and gid_t change will get it up and running. + +--------------------------------------------- +NeXT machines running NeXTStep 3.2: +--------------------------------------------- + +1. Run configure with predefined CPP: + CPP='cc -E' ./configure + (If your shell is [t]csh, do a "setenv CPP 'cc -E' ") + +2. Edit Makefile: + -add tmpnam.o to COMPAT_OBJS: + COMPAT_OBJS = getcwd.o waitpid.o strtod.o tmpnam.o + -add the following to AC_FLAGS: + -Dstrtod=tcl_strtod + -add '-m' to MATH_LIBS: + MATH_LIBS = -m -lm + -add '-O2 -arch m68k -arch i386' to CFLAGS: + CFLAGS = -O2 -arch m68k -arch i386 + +------------------------------------------------- +ISC 2.2 UNIX (using standard ATT SYSV compiler): +------------------------------------------------- + +In Makefile, change + +CFLAGS = -g -I. -DTCL_LIBRARY=\"${TCL_LIBRARY}\" + +to + +CFLAGS = -g -I. -DPOSIX_JC -DTCL_LIBRARY=\"${TCL_LIBRARY}\" + +This brings in the typedef for pid_t, which is needed for +/usr/include/sys/wait.h in tclUnix.h. + +--------------------------------------------- +DEC Alphas: +--------------------------------------------- + +1. There appears to be a compiler/library bug that causes core-dumps +unless you compile tclVar.c without optimization (remove the -O compiler +switch). The problem appears to have been fixed in the 1.3-4 version +of the compiler. + +--------------------------------------------- +CDC 4680MP, EP/IX 1.4.3: +--------------------------------------------- + +The installation was done in the System V environment (-systype sysv) +with the BSD extensions available (-I/usr/include/bsd and -lbsd). It was +built with the 2.20 level C compiler. The 2.11 level should not be used +because it has a problem with detecting NaN values in lines like: + if (x != x) ... +which appear in the TCL code. + +To make the configure script find the BSD extensions, I set environment +variable DEFS to "-I/usr/include/bsd" and LIBS to "-lbsd" before +running it. I would have also set CC to "cc2.20", but that compiler +driver has a bug that loader errors (e.g. not finding a library routine, +which the script uses to tell what is available) do not cause an error +status to be returned to the shell (but see the comments about "-non_shared" +below in the 2.1.1 notes). + +There is a bug in the <sys/wait.h> include file that mis-defines the +structure fields and causes WIFEXITED and WIFSIGNALED to return incorrect +values. My solution was to create a subdirectory "sys" of the main TCL +source directory and put a corrected wait.h in it. The "-I." already on +all the compile lines causes it to be used instead of the system version. +To fix this, compare the structure definition in /usr/include/bsd/sys/wait.h +with /bsd43/include/sys/wait.h (or mail to John Jackson, jrj@cc.purdue.edu, +and he'll send you a context diff). + +After running configure, I made the following changes to Makefile: + + 1) In AC_FLAGS, change: + -DNO_WAIT3=1 + to + -DNO_WAIT3=0 -Dwait3=wait2 + EP/IX (in the System V environment) provides a wait2() system + call with what TCL needs (the WNOHANG flag). The extra parameter + TCL passes to what it thinks is wait3() (the resources used by + the child process) is always zero and will be safely ignored. + + 2) Change: + CC=cc + to + CC=cc2.20 + because of the NaN problem mentioned earlier. Skip this if the + default compiler is already 2.20 (or later). + + 3) Add "-lbsd" to the commands that create tclsh and tcltest + (look for "-o"). + +--------------------------------------------- +CDC 4680MP, EP/IX 2.1.1: +--------------------------------------------- + +The installation was done in the System V environment (-systype sysv) +with the BSD extensions available (-I/usr/include/bsd and -lbsd). It was +built with the 3.11 level C compiler. The 2.11 level should not be used +because it has a problem with detecting NaN values in lines like: + if (x != x) ... +which appear in the TCL code. The 2.20 compiler does not have this +problem. + +To make the configure script find the BSD extensions, I set environment +variable DEFS to: + + "-I/usr/include/bsd -D__STDC__=0 -non_shared" + +and LIBS to: + + "-lbsd" + +before running it. The "-non_shared" is needed because with shared +libraries, the compiler (actually, the loader) does not report an +error for "missing" routines. The configuration script depends on this +error to know what routines are available. This is the real problem +I reported above for EP/IX 1.4.3 that I incorrectly attributed to a +compiler driver bug. I don't have 1.4.3 available any more, but it's +possible using "-non_shared" on it would have solved the problem. + +The same <sys/wait.h> bug exists at 2.1.1 (yes, I have reported it to +CDC), and the same fix as described in the 1.4.3 porting notes works. + +In addition to the three Makefile changes described in the 1.4.3 notes, +you can remove the "-non_shared" flag from AC_FLAGS. It is only needed +for the configuration step, not the build. + +You will get duplicate definition compilation warnings of: + + DBL_MIN + DBL_MAX + FLT_MIN + FLT_MAX + +during tclExpr.c. These can be ignored. + +During expr.test, you will get a failure for one of the "fmod" tests +unless you have CDC patch CC40038311 installed. + +--------------------------------------------- +Convex systems, OS 10.1 and 10.2: +Contact: Lennart Sorth (ls@dmi.min.dk) +--------------------------------------------- + +1. tcl7.0b2 compiles on Convex systems (OS 10.1 and 10.2) by just running + configure, typing make, except tclUnixUtil.c needs to be compiled + with option "-pcc" (portable cc, =!ANSI) due to: + cc: Error on line 1111 of tclUnixUtil.c: 'waitpid' redeclared: + incompatible types. + +------------------------------------------------- +Pyramid, OSx 5.1a (UCB universe, GCC installed): +------------------------------------------------- + +1. The procedures memcpy, strchr, fmod, and strrchr are all missing, +so you'll need to provide substitutes for them. After you do that +everything should compile fine. There will be one error in a scan +test, but it's an obscure one because of a non-ANSI implementation +of sscanf on the machine; you can ignore it. + +2. You may also have to add "tmpnam.o" to COMPAT_OBJS in Makefile: +the system version appears to be bad. + +------------------------------------------------- +Encore 91, UMAX V 3.0.9.3: +------------------------------------------------- + +1. Modify the CFLAGS assignment in file Makefile.in to include the +-DENCORE flag in Makefile: + + CFLAGS = -O -DENCORE + +2. "mkdir" does not by default create the parent directories. The mkdir +directives should be modified to "midir -p". + +------------------------------------------------- +Sequent machines running Dynix: +Contact: Andrew Swan (aswan@soda.berkeley.edu) +------------------------------------------------- + +1. Use gcc instead of the cc distributed by Sequent + +2. The distributed math library does not include the fmod + function. Source for fmod can be retrieved from a BSD + source archive (such as ftp.uu.net) and included in the + compat directory. Add fmod.o to the COMPAT_OBJS variable + in the Makefile. You may need to comment out references + to 'isnan' and 'finite' in fmod.c + +3. If the linker complains that there are two copies of the + 'tanh' function, use the ar command to extract the objects + from the math library and build a new one without tanh.o + +4. The *scanf functions in the Sequent libraries are apparently + broken, which will cause the scanning tests to fail. The + cases that fail are fairly obscure. Using GNU libc apparently + solves this problem. + +------------------------------------------------- +Systems running Interactive 4.0: +------------------------------------------------- + +1. Add "-posix -D_SYSV3" to CFLAGS in Makefile (or Makefile.in). + +------------------------------------------------- +Systems running FreeBSD 1.1.5.1: +------------------------------------------------- + +The following changes comprise the entire porting effort of tcl7.3 to +FreeBSD (i.e. these were the changes to tclTest.c) and should probably +be made part of the tcl distribution. The changes only effect the way that +floating point exceptions are reported. I've choosen to move the changes +out of tclTest.c and into tclBasic.c. + +in tclBasic.c at top-of-file: + +#ifdef BSD_NET2 +#include <floatingpoint.h> +#endif + +in tclBasic.c in Tcl_Init(): + +#ifdef BSD_NET2 + fpsetround(FP_RN); + fpsetmask(0L); +#endif + diff --git a/unix/tclAppInit.c b/unix/tclAppInit.c new file mode 100644 index 0000000..fafa31e --- /dev/null +++ b/unix/tclAppInit.c @@ -0,0 +1,136 @@ +/* + * 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. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclAppInit.c 1.20 97/03/24 14:29:43 + */ + +#ifdef TCL_XT_TEST +#include <X11/Intrinsic.h> +#endif + +#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 +EXTERN int TclObjTest_Init _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN int Tcltest_Init _ANSI_ARGS_((Tcl_Interp *interp)); +#endif /* TCL_TEST */ +#ifdef TCL_XT_TEST +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. */ +{ +#ifdef TCL_XT_TEST + XtToolkitInitialize(); +#endif + Tcl_Main(argc, argv, Tcl_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 interp->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; + } +#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 new file mode 100644 index 0000000..905aa84 --- /dev/null +++ b/unix/tclConfig.sh.in @@ -0,0 +1,116 @@ +# 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. +# +# SCCS: @(#) tclConfig.sh.in 1.20 97/07/01 11:40:19 + +# 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@' + +# 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@ + +# 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@' + +# Base command to use for combining object files into a shared library: +TCL_SHLIB_LD='@SHLIB_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='@LD_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. 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@' + +# 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='@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='@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@' diff --git a/unix/tclLoadAix.c b/unix/tclLoadAix.c new file mode 100644 index 0000000..edf33d6 --- /dev/null +++ b/unix/tclLoadAix.c @@ -0,0 +1,549 @@ +/* + * 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. + * + * SCCS: @(#) tclLoadAix.c 1.11 96/10/07 10:41:24 + * + * 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)) { + 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))); + 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 new file mode 100644 index 0000000..ade7161 --- /dev/null +++ b/unix/tclLoadAout.c @@ -0,0 +1,470 @@ +/* + * 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. + * + * SCCS: @(#) tclLoadAout.c 1.9 97/02/22 14:05:01 + */ + +#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)); + +/* + *---------------------------------------------------------------------- + * + * TclLoadFile -- + * + * 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 interp->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 +TclLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr) + 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. */ +{ + 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; + + /* 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, + N_TXTOFF (relocatedHead.ex_f, relocatedHead.ex_o), + SEEK_SET); +#else + status = lseek (relocatedFd, 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 interp->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; + + /* Open the load module */ + + if ((f = fopen (fileName, "rb")) == 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; +} + +/* + *---------------------------------------------------------------------- + * + * 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; + + 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); + + if (islower(UCHAR(*r))) { + *r = (char) toupper(UCHAR(*r)); + } + while (*(++r)) { + if (isupper(UCHAR(*r))) { + *r = (char) tolower(UCHAR(*r)); + } + } + + return 1; +} diff --git a/unix/tclLoadDl.c b/unix/tclLoadDl.c new file mode 100644 index 0000000..2619bfd --- /dev/null +++ b/unix/tclLoadDl.c @@ -0,0 +1,135 @@ +/* + * 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 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: @(#) tclLoadDl.c 1.8 96/12/03 16:57:00 + */ + +#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 + +/* + *---------------------------------------------------------------------- + * + * TclLoadFile -- + * + * 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 interp->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 +TclLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr) + 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. */ +{ + VOID *handle; + Tcl_DString newName; + + handle = dlopen(fileName, RTLD_NOW | RTLD_GLOBAL); + 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. + */ + + *proc1Ptr = (Tcl_PackageInitProc *) dlsym(handle, (char *) sym1); + if (*proc1Ptr == NULL) { + Tcl_DStringInit(&newName); + Tcl_DStringAppend(&newName, "_", 1); + Tcl_DStringAppend(&newName, sym1, -1); + *proc1Ptr = (Tcl_PackageInitProc *) dlsym(handle, + Tcl_DStringValue(&newName)); + Tcl_DStringFree(&newName); + } + *proc2Ptr = (Tcl_PackageInitProc *) dlsym(handle, (char *) sym2); + if (*proc2Ptr == NULL) { + Tcl_DStringInit(&newName); + Tcl_DStringAppend(&newName, "_", 1); + Tcl_DStringAppend(&newName, sym2, -1); + *proc2Ptr = (Tcl_PackageInitProc *) dlsym(handle, + Tcl_DStringValue(&newName)); + Tcl_DStringFree(&newName); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * 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 new file mode 100644 index 0000000..0ef994a --- /dev/null +++ b/unix/tclLoadDld.c @@ -0,0 +1,125 @@ +/* + * 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 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: @(#) tclLoadDld.c 1.5 97/05/14 13:24:22 + */ + +#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 + +/* + *---------------------------------------------------------------------- + * + * TclLoadFile -- + * + * 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 interp->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 +TclLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr) + 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. */ +{ + 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); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * 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 new file mode 100644 index 0000000..ed4b823 --- /dev/null +++ b/unix/tclLoadNext.c @@ -0,0 +1,111 @@ +/* + * 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 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: @(#) tclLoadNext.c 1.4 96/02/15 11:58:55 + */ + +#include "tclInt.h" +#include <mach-o/rld.h> +#include <streams/streams.h> + +/* + *---------------------------------------------------------------------- + * + * TclLoadFile -- + * + * 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 interp->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 +TclLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr) + 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. */ +{ + 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); + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * 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 new file mode 100644 index 0000000..ca8c8fc --- /dev/null +++ b/unix/tclLoadOSF.c @@ -0,0 +1,128 @@ +/* + * 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 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: @(#) tclLoadOSF.c 1.2 96/02/15 11:58:40 + */ + +#include "tclInt.h" +#include <sys/types.h> +#include <loader.h> + +/* + *---------------------------------------------------------------------- + * + * TclLoadFile -- + * + * 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 interp->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 +TclLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr) + 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. */ +{ + 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; + } + + /* + * 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; +} + +/* + *---------------------------------------------------------------------- + * + * 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 new file mode 100644 index 0000000..2f290ab --- /dev/null +++ b/unix/tclLoadShl.c @@ -0,0 +1,129 @@ +/* + * 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-1996 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclLoadShl.c 1.5 96/03/15 15:01:44 + */ + +#include <dl.h> + +/* + * On some HP machines, dl.h defines EXTERN; remove that definition. + */ + +#ifdef EXTERN +# undef EXTERN +#endif + +#include "tcl.h" + +/* + *---------------------------------------------------------------------- + * + * TclLoadFile -- + * + * 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 interp->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 +TclLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr) + 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. */ +{ + shl_t handle; + Tcl_DString newName; + + handle = shl_load(fileName, BIND_IMMEDIATE, 0L); + if (handle == NULL) { + Tcl_AppendResult(interp, "couldn't load file \"", fileName, + "\": ", Tcl_PosixError(interp), (char *) NULL); + return TCL_ERROR; + } + + /* + * 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; +} + +/* + *---------------------------------------------------------------------- + * + * 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 new file mode 100644 index 0000000..24b815d --- /dev/null +++ b/unix/tclMtherr.c @@ -0,0 +1,86 @@ +/* + * 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. + * + * SCCS: @(#) tclMtherr.c 1.12 96/06/22 16:36:57 + */ + +#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 variable is secretly shared with Tcl so we can + * tell if expression evaluation is in progress. If not, matherr + * just emulates the default behavior, which includes printing + * a message. + */ + +extern int tcl_MathInProgress; + +/* + * 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 (!tcl_MathInProgress) { + 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 new file mode 100644 index 0000000..2c0e996 --- /dev/null +++ b/unix/tclUnixChan.c @@ -0,0 +1,2565 @@ +/* + * tclUnixChan.c + * + * Common channel driver for Unix channels based on files, command + * pipes and TCP sockets. + * + * Copyright (c) 1995-1997 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclUnixChan.c 1.207 97/11/04 14:45:29 + */ + +#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 + +#ifdef USE_TERMIOS +# include <termios.h> +#else /* !USE_TERMIOS */ +#ifdef USE_TERMIO +# include <termio.h> +#else /* !USE_TERMIO */ +#ifdef USE_SGTTY +# include <sgtty.h> +#endif /* USE_SGTTY */ +#endif /* !USE_TERMIO */ +#endif /* !USE_TERMIOS */ + +/* + * 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; + +/* + * 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; + +/* + * List of all file channels currently open. + */ + +static FileState *firstFilePtr = NULL; + +/* + * 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)); +static int TtyParseMode _ANSI_ARGS_((Tcl_Interp *interp, + CONST char *mode, int *speedPtr, int *parityPtr, + int *dataPtr, int *stopPtr)); +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 void TtyInit _ANSI_ARGS_((int fd)); +static void TtySetAttributes _ANSI_ARGS_((int fd, + TtyAttrs *ttyPtr)); +static int TtySetOptionProc _ANSI_ARGS_((ClientData instanceData, + Tcl_Interp *interp, char *optionName, + char *value)); +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. */ +}; + +/* + * 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.*/ + FileCloseProc, /* 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. */ +}; + +/* + * 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; + + Tcl_DeleteFileHandler(fsPtr->fd); + if (!TclInExit() + || ((fsPtr->fd != 0) && (fsPtr->fd != 1) && (fsPtr->fd != 2))) { + if (close(fsPtr->fd) < 0) { + errorCode = errno; + } + } + for (nextPtrPtr = &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, 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_GetChannelFile 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; + } +} + +/* + *---------------------------------------------------------------------- + * + * TtySetOptionProc -- + * + * Sets an option on a channel. + * + * Results: + * A standard Tcl result. Also sets interp->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[32]; + 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 */ + + +/* + *--------------------------------------------------------------------------- + * + * 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. + * + *--------------------------------------------------------------------------- + */ + +static void +TtyInit(fd) + int fd; /* Open file descriptor for serial port to + * be initialized. */ +{ +#ifdef USE_TERMIOS + struct termios termios; + + tcgetattr(fd, &termios); + termios.c_iflag = IGNBRK; + termios.c_oflag = 0; + termios.c_lflag = 0; + termios.c_cflag |= CREAD; + termios.c_cc[VMIN] = 60; + termios.c_cc[VTIME] = 2; + tcsetattr(fd, TCSANOW, &termios); +#else /* !USE_TERMIOS */ +#ifdef USE_TERMIO + struct termio termio; + + ioctl(fd, TCGETA, &termio); + termio.c_iflag = IGNBRK; + termio.c_oflag = 0; + termio.c_lflag = 0; + termio.c_cflag |= CREAD; + termio.c_cc[VMIN] = 60; + termio.c_cc[VTIME] = 2; + ioctl(fd, TCSETAW, &termio); +#else /* !USE_TERMIO */ +#ifdef USE_SGTTY + struct sgttyb sgttyb; + + ioctl(fd, TIOCGETP, &sgttyb); + sgttyb.sg_flags &= (EVENP | ODDP); + sgttyb.sg_flags |= RAW; + ioctl(fd, TIOCSETP, &sgttyb); +#endif /* USE_SGTTY */ +#endif /* !USE_TERMIO */ +#endif /* !USE_TERMIOS */ +} + +/* + *--------------------------------------------------------------------------- + * + * 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. */ +{ +#ifdef USE_TERMIOS + int parity, data; + struct termios termios; + + tcgetattr(fd, &termios); + ttyPtr->baud = TtyGetBaud(cfgetospeed(&termios)); + + parity = 'n'; +#ifdef PAREXT + switch ((int) (termios.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) (termios.c_cflag & (PARENB | PARODD))) { + case PARENB : parity = 'e'; break; + case PARENB | PARODD : parity = 'o'; break; + } +#endif /* !PAREXT */ + ttyPtr->parity = parity; + + data = termios.c_cflag & CSIZE; + ttyPtr->data = (data == CS5) ? 5 : (data == CS6) ? 6 : + (data == CS7) ? 7 : 8; + + ttyPtr->stop = (termios.c_cflag & CSTOPB) ? 2 : 1; +#else /* !USE_TERMIOS */ +#ifdef USE_TERMIO + int parity, data; + struct termio termio; + + ioctl(fd, TCGETA, &termio); + ttyPtr->baud = TtyGetBaud(termio.c_cflag & CBAUD); + parity = 'n'; + switch (termio.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; + } + ttyPtr->parity = parity; + + data = termio.c_cflag & CSIZE; + ttyPtr->data = (data == CS5) ? 5 : (data == CS6) ? 6 : + (data == CS7) ? 7 : 8; + + ttyPtr->stop = (termio.c_cflag & CSTOPB) ? 2 : 1; +#else /* !USE_TERMIO */ +#ifdef USE_SGTTY + int parity; + struct sgttyb sgttyb; + + ioctl(fd, TIOCGETP, &sgttyb); + ttyPtr->baud = TtyGetBaud(sgttyb.sg_ospeed); + parity = 'n'; + if (sgttyb.sg_flags & EVENP) { + parity = 'e'; + } else if (sgttyb.sg_flags & ODDP) { + parity = 'o'; + } + ttyPtr->parity = parity; + ttyPtr->data = (sgttyb.sg_flags & (EVENP | ODDP)) ? 7 : 8; + ttyPtr->stop = 1; +#else /* !USE_SGTTY */ + ttyPtr->baud = 0; + ttyPtr->parity = 'n'; + ttyPtr->data = 0; + ttyPtr->stop = 0; +#endif /* !USE_SGTTY */ +#endif /* !USE_TERMIO */ +#endif /* !USE_TERMIOS */ +} + +/* + *--------------------------------------------------------------------------- + * + * 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. */ +{ +#ifdef USE_TERMIOS + int parity, data, flag; + struct termios termios; + + tcgetattr(fd, &termios); + cfsetospeed(&termios, TtyGetSpeed(ttyPtr->baud)); + cfsetispeed(&termios, TtyGetSpeed(ttyPtr->baud)); + + flag = 0; + parity = ttyPtr->parity; + if (parity != 'n') { + flag |= PARENB; +#ifdef PAREXT + termios.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; + } + + termios.c_cflag &= ~(PARENB | PARODD | CSIZE | CSTOPB); + termios.c_cflag |= flag; + tcsetattr(fd, TCSANOW, &termios); + +#else /* !USE_TERMIOS */ +#ifdef USE_TERMIO + int parity, data, flag; + struct termio termio; + + ioctl(fd, TCGETA, &termio); + termio.c_cflag &= ~CBAUD; + termio.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; + } + + termio.c_cflag &= ~(PARENB | PARODD | PAREXT | CSIZE | CSTOPB); + termio.c_cflag |= flag; + ioctl(fd, TCSETAW, &termio); + +#else /* !USE_TERMIO */ +#ifdef USE_SGTTY + int parity; + struct sgttyb sgttyb; + + ioctl(fd, TIOCGETP, &sgttyb); + sgttyb.sg_ospeed = TtyGetSpeed(ttyPtr->baud); + sgttyb.sg_ispeed = TtyGetSpeed(ttyPtr->baud); + + parity = ttyPtr->parity; + if (parity == 'e') { + sgttyb.sg_flags &= ~ODDP; + sgttyb.sg_flags |= EVENP; + } else if (parity == 'o') { + sgttyb.sg_flags &= ~EVENP; + sgttyb.sg_flags |= ODDP; + } + ioctl(fd, TIOCSETP, &sgttyb); +#endif /* USE_SGTTY */ +#endif /* !USE_TERMIO */ +#endif /* !USE_TERMIOS */ +} + +/* + *--------------------------------------------------------------------------- + * + * 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 interp->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; + } + if (strchr("noems", parity) == NULL) { + if (interp != NULL) { + Tcl_AppendResult(interp, bad, + " parity: should be n, o, e, m, or s", 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; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_OpenFileChannel -- + * + * 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 interp->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 +Tcl_OpenFileChannel(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 *nativeName, channelName[20]; + Tcl_DString buffer; + Tcl_ChannelType *channelTypePtr; + + 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("Tcl_OpenFileChannel: invalid mode value"); + return NULL; + } + + nativeName = Tcl_TranslateFileName(interp, fileName, &buffer); + if (nativeName == NULL) { + return NULL; + } + fd = open(nativeName, mode, permissions); + + /* + * If nativeName is not NULL, the buffer is valid and we must free + * the storage. + */ + + 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); + + fsPtr = (FileState *) ckalloc((unsigned) sizeof(FileState)); + fsPtr->nextPtr = firstFilePtr; + firstFilePtr = fsPtr; + fsPtr->validMask = channelPermissions | TCL_EXCEPTION; + fsPtr->fd = fd; + + 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. + */ + + TtyInit(fd); + channelTypePtr = &ttyChannelType; + } else { + channelTypePtr = &fileChannelType; + } + + 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 (channelTypePtr == &ttyChannelType) { + /* + * 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", + "auto crlf") != 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[20]; + int fd = (int) handle; + + 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 = firstFilePtr; fsPtr != NULL; fsPtr = fsPtr->nextPtr) { + if (fsPtr->fd == fd) { + return (mode == fsPtr->validMask) ? fsPtr->channel : NULL; + } + } + + fsPtr = (FileState *) ckalloc((unsigned) sizeof(FileState)); + fsPtr->nextPtr = firstFilePtr; + 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, 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, 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[128]; + + if (optionName != (char *) NULL) { + len = strlen(optionName); + } + + 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((char *) &(peername.sin_addr), + sizeof(peername.sin_addr), AF_INET); + if (hostEntPtr != (struct hostent *) NULL) { + Tcl_DStringAppendElement(dsPtr, hostEntPtr->h_name); + } else { + Tcl_DStringAppendElement(dsPtr, inet_ntoa(peername.sin_addr)); + } + sprintf(buf, "%d", 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((char *) &(sockname.sin_addr), + sizeof(sockname.sin_addr), AF_INET); + if (hostEntPtr != (struct hostent *) NULL) { + Tcl_DStringAppendElement(dsPtr, hostEntPtr->h_name); + } else { + Tcl_DStringAppendElement(dsPtr, inet_ntoa(sockname.sin_addr)); + } + sprintf(buf, "%d", 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; + + if (mask) { + Tcl_CreateFileHandler(statePtr->fd, mask, + (Tcl_FileProc *) Tcl_NotifyChannel, + (ClientData) statePtr->channel); + } else { + Tcl_DeleteFileHandler(statePtr->fd); + } +} + +/* + *---------------------------------------------------------------------- + * + * TcpGetHandleProc -- + * + * Called from Tcl_GetChannelFile 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 interp->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; + } + } + } + } + +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 { + addr.s_addr = inet_addr(host); + if (addr.s_addr == -1) { + hostent = gethostbyname(host); + 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 + return 0; /* error */ + } + } + } + + /* + * NOTE: On 64 bit machines the assignment below is rumored to not + * do the right thing. Please report errors related to this if you + * observe incorrect behavior on 64 bit machines such as DEC Alphas. + * Should we modify this code to do an explicit memcpy? + */ + + sockaddrPtr->sin_addr.s_addr = addr.s_addr; + return 1; /* Success. */ +} + +/* + *---------------------------------------------------------------------- + * + * 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[20]; + + /* + * 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[20]; + + 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 interp->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[20]; + + /* + * 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[20]; + + 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 = (Tcl_TcpAcceptProc *) NULL; + newSockState->acceptProcData = (ClientData) NULL; + + sprintf(channelName, "sock%d", newsock); + newSockState->channel = Tcl_CreateChannel(&tcpChannelType, channelName, + (ClientData) newSockState, (TCL_READABLE | TCL_WRITABLE)); + + Tcl_SetChannelOption((Tcl_Interp *) NULL, newSockState->channel, + "-translation", "auto crlf"); + + if (sockState->acceptProc != (Tcl_TcpAcceptProc *) NULL) { + (sockState->acceptProc) (sockState->acceptProcData, + newSockState->channel, inet_ntoa(addr.sin_addr), + ntohs(addr.sin_port)); + } +} + +/* + *---------------------------------------------------------------------- + * + * TclGetDefaultStdChannel -- + * + * 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 +TclGetDefaultStdChannel(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); + + /* + * 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 interp->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) || (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; + static 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 new file mode 100644 index 0000000..24841ca --- /dev/null +++ b/unix/tclUnixEvent.c @@ -0,0 +1,76 @@ +/* + * 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. + * + * SCCS: @(#) tclUnixEvent.c 1.1 97/03/04 14:19:34 + */ + +#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. */ +{ + static 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 new file mode 100644 index 0000000..3ec1a69 --- /dev/null +++ b/unix/tclUnixFCmd.c @@ -0,0 +1,1224 @@ +/* + * 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-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: @(#) tclUnixFCmd.c 1.31 97/10/13 16:51:14 + * + * 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> + +/* + * 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, char *fileName, + Tcl_Obj **attributePtrPtr)); +static int GetOwnerAttribute _ANSI_ARGS_((Tcl_Interp *interp, + int objIndex, char *fileName, + Tcl_Obj **attributePtrPtr)); +static int GetPermissionsAttribute _ANSI_ARGS_(( + Tcl_Interp *interp, int objIndex, char *fileName, + Tcl_Obj **attributePtrPtr)); +static int SetGroupAttribute _ANSI_ARGS_((Tcl_Interp *interp, + int objIndex, char *fileName, + Tcl_Obj *attributePtr)); +static int SetOwnerAttribute _ANSI_ARGS_((Tcl_Interp *interp, + int objIndex, char *fileName, + Tcl_Obj *attributePtr)); +static int SetPermissionsAttribute _ANSI_ARGS_(( + Tcl_Interp *interp, int objIndex, char *fileName, + Tcl_Obj *attributePtr)); + +/* + * Prototype for the TraverseUnixTree callback function. + */ + +typedef int (TraversalProc) _ANSI_ARGS_((char *src, char *dst, + struct stat *sb, 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_((char *src, char *dst, + struct stat *srcStatBufPtr)); +static int CopyFileAtts _ANSI_ARGS_((char *src, char *dst, + struct stat *srcStatBufPtr)); +static int TraversalCopy _ANSI_ARGS_((char *src, char *dst, + struct stat *sbPtr, int type, + Tcl_DString *errorPtr)); +static int TraversalDelete _ANSI_ARGS_((char *src, char *dst, + struct stat *sbPtr, int type, + Tcl_DString *errorPtr)); +static int TraverseUnixTree _ANSI_ARGS_(( + TraversalProc *traversalProc, + Tcl_DString *sourcePath, Tcl_DString *destPath, + Tcl_DString *errorPtr)); + +/* + *--------------------------------------------------------------------------- + * + * TclpRenameFile -- + * + * 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) + char *src; /* Pathname of file or dir to be renamed. */ + char *dst; /* New pathname of file or directory. */ +{ + if (rename(src, dst) == 0) { + return TCL_OK; + } + if (errno == ENOTEMPTY) { + errno = EEXIST; + } + +#ifdef sparc + /* + * 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() is only defined on SunOS. + */ + + if (errno == EINVAL) { + char srcPath[MAXPATHLEN], dstPath[MAXPATHLEN]; + DIR *dirPtr; + struct dirent *dirEntPtr; + + if ((realpath(src, srcPath) != NULL) + && (realpath(dst, dstPath) != NULL) + && (strncmp(srcPath, dstPath, strlen(srcPath)) != 0)) { + dirPtr = opendir(dst); + if (dirPtr != NULL) { + while ((dirEntPtr = readdir(dirPtr)) != NULL) { + if ((strcmp(dirEntPtr->d_name, ".") != 0) && + (strcmp(dirEntPtr->d_name, "..") != 0)) { + errno = EEXIST; + closedir(dirPtr); + return TCL_ERROR; + } + } + closedir(dirPtr); + } + } + errno = EINVAL; + } +#endif /* sparc */ + + 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 -- + * + * 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) + char *src; /* Pathname of file to be copied. */ + char *dst; /* Pathname of file to copy to. */ +{ + struct stat srcStatBuf, dstStatBuf; + char link[MAXPATHLEN]; + int length; + + /* + * Have to do a stat() to determine the filetype. + */ + + if (lstat(src, &srcStatBuf) != 0) { + 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) { + if (S_ISDIR(dstStatBuf.st_mode)) { + errno = EISDIR; + return TCL_ERROR; + } + } + if (unlink(dst) != 0) { + if (errno != ENOENT) { + return TCL_ERROR; + } + } + + switch ((int) (srcStatBuf.st_mode & S_IFMT)) { + case S_IFLNK: + length = readlink(src, link, sizeof(link)); + if (length == -1) { + return TCL_ERROR; + } + link[length] = '\0'; + if (symlink(link, dst) < 0) { + return TCL_ERROR; + } + break; + + case S_IFBLK: + case S_IFCHR: + if (mknod(dst, srcStatBuf.st_mode, srcStatBuf.st_rdev) < 0) { + return TCL_ERROR; + } + return CopyFileAtts(src, dst, &srcStatBuf); + + case S_IFIFO: + if (mkfifo(dst, srcStatBuf.st_mode) < 0) { + 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, srcStatBufPtr) + char *src; /* Pathname of file to copy. */ + char *dst; /* Pathname of file to create/overwrite. */ + struct stat *srcStatBufPtr; /* 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) { + return TCL_ERROR; + } + + dstFd = open(dst, O_CREAT | O_TRUNC | O_WRONLY, srcStatBufPtr->st_mode); + if (dstFd < 0) { + close(srcFd); + return TCL_ERROR; + } + +#if HAVE_ST_BLKSIZE + blockSize = srcStatBufPtr->st_blksize; +#else + blockSize = 4096; +#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); + return TCL_ERROR; + } + if (CopyFileAtts(src, dst, srcStatBufPtr) == 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); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * TclpDeleteFile -- + * + * 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) + char *path; /* Pathname of file to be removed. */ +{ + if (unlink(path) != 0) { + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * TclpCreateDirectory -- + * + * Creates the specified directory. All parent directories of the + * specified directory must already exist. The directory is + * automatically created with permissions so that user can access + * the new directory and create new files or subdirectories in it. + * + * Results: + * If the directory was successfully created, returns TCL_OK. + * Otherwise the return value is TCL_ERROR and errno is set to + * indicate the error. Some possible values for errno are: + * + * EACCES: a parent directory can't be read and/or written. + * EEXIST: path already exists. + * ENOENT: a parent directory doesn't exist. + * + * Side effects: + * A directory is created with the current umask, except that + * permission for u+rwx will always be added. + * + *--------------------------------------------------------------------------- + */ + +int +TclpCreateDirectory(path) + char *path; /* Pathname of directory to create. */ +{ + mode_t mode; + + mode = umask(0); + umask(mode); + + /* + * umask return value is actually the inverse of the permissions. + */ + + mode = (0777 & ~mode); + + if (mkdir(path, mode | S_IRUSR | S_IWUSR | S_IXUSR) != 0) { + 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) + char *src; /* Pathname of directory to be copied. */ + char *dst; /* Pathname of target directory. */ + Tcl_DString *errorPtr; /* If non-NULL, initialized DString for + * error reporting. */ +{ + int result; + Tcl_DString srcBuffer; + Tcl_DString dstBuffer; + + Tcl_DStringInit(&srcBuffer); + Tcl_DStringInit(&dstBuffer); + Tcl_DStringAppend(&srcBuffer, src, -1); + Tcl_DStringAppend(&dstBuffer, dst, -1); + result = TraverseUnixTree(TraversalCopy, &srcBuffer, &dstBuffer, + errorPtr); + Tcl_DStringFree(&srcBuffer); + Tcl_DStringFree(&dstBuffer); + return result; +} + +/* + *--------------------------------------------------------------------------- + * + * TclpRemoveDirectory -- + * + * 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) + char *path; /* Pathname of directory to be removed. */ + int recursive; /* If non-zero, removes directories that + * are nonempty. Otherwise, will only remove + * empty directories. */ + Tcl_DString *errorPtr; /* If non-NULL, initialized DString for + * error reporting. */ +{ + int result; + Tcl_DString buffer; + + if (rmdir(path) == 0) { + return TCL_OK; + } + if (errno == ENOTEMPTY) { + errno = EEXIST; + } + if ((errno != EEXIST) || (recursive == 0)) { + if (errorPtr != NULL) { + Tcl_DStringAppend(errorPtr, path, -1); + } + return TCL_ERROR; + } + + /* + * The directory is nonempty, but the recursive flag has been + * specified, so we recursively remove all the files in the directory. + */ + + Tcl_DStringInit(&buffer); + Tcl_DStringAppend(&buffer, path, -1); + result = TraverseUnixTree(TraversalDelete, &buffer, NULL, errorPtr); + Tcl_DStringFree(&buffer); + return result; +} + +/* + *--------------------------------------------------------------------------- + * + * 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. */ + Tcl_DString *targetPtr; /* Pathname of directory to traverse in + * parallel with source directory. */ + Tcl_DString *errorPtr; /* If non-NULL, an initialized DString for + * error reporting. */ +{ + struct stat statbuf; + char *source, *target, *errfile; + int result, sourceLen; + int targetLen = 0; /* Initialization needed only to prevent + * warning in gcc. */ + struct dirent *dirp; + DIR *dp; + + result = TCL_OK; + source = Tcl_DStringValue(sourcePtr); + if (targetPtr != NULL) { + target = Tcl_DStringValue(targetPtr); + } else { + target = NULL; + } + + errfile = NULL; + if (lstat(source, &statbuf) != 0) { + errfile = source; + goto end; + } + if (!S_ISDIR(statbuf.st_mode)) { + /* + * Process the regular file + */ + + return (*traverseProc)(source, target, &statbuf, DOTREE_F, errorPtr); + } + + dp = opendir(source); + if (dp == NULL) { + /* + * Can't read directory + */ + + errfile = source; + goto end; + } + result = (*traverseProc)(source, target, &statbuf, DOTREE_PRED, errorPtr); + if (result != TCL_OK) { + closedir(dp); + return result; + } + + Tcl_DStringAppend(sourcePtr, "/", 1); + source = Tcl_DStringValue(sourcePtr); + sourceLen = Tcl_DStringLength(sourcePtr); + + if (targetPtr != NULL) { + Tcl_DStringAppend(targetPtr, "/", 1); + target = Tcl_DStringValue(targetPtr); + targetLen = Tcl_DStringLength(targetPtr); + } + + while ((dirp = readdir(dp)) != NULL) { + if ((strcmp(dirp->d_name, ".") == 0) + || (strcmp(dirp->d_name, "..") == 0)) { + continue; + } + + /* + * Append name after slash, and recurse on the file. + */ + + Tcl_DStringAppend(sourcePtr, dirp->d_name, -1); + if (targetPtr != NULL) { + Tcl_DStringAppend(targetPtr, dirp->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(dp); + + /* + * Strip off the trailing slash we added + */ + + Tcl_DStringSetLength(sourcePtr, sourceLen - 1); + source = Tcl_DStringValue(sourcePtr); + if (targetPtr != NULL) { + Tcl_DStringSetLength(targetPtr, targetLen - 1); + target = Tcl_DStringValue(targetPtr); + } + + if (result == TCL_OK) { + /* + * Call traverseProc() on a directory after visiting all the + * files in that directory. + */ + + result = (*traverseProc)(source, target, &statbuf, DOTREE_POSTD, + errorPtr); + } + end: + if (errfile != NULL) { + if (errorPtr != NULL) { + Tcl_DStringAppend(errorPtr, errfile, -1); + } + 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(src, dst, sbPtr, type, errorPtr) + char *src; /* Source pathname to copy. */ + char *dst; /* Destination pathname of copy. */ + struct stat *sbPtr; /* Stat info for file specified by src. */ + int type; /* Reason for call - see TraverseUnixTree(). */ + Tcl_DString *errorPtr; /* If non-NULL, initialized DString for + * error return. */ +{ + switch (type) { + case DOTREE_F: + if (TclpCopyFile(src, dst) == TCL_OK) { + return TCL_OK; + } + break; + + case DOTREE_PRED: + if (TclpCreateDirectory(dst) == TCL_OK) { + return TCL_OK; + } + break; + + case DOTREE_POSTD: + if (CopyFileAtts(src, dst, sbPtr) == 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_DStringAppend(errorPtr, dst, -1); + } + 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(src, ignore, sbPtr, type, errorPtr) + char *src; /* Source pathname. */ + char *ignore; /* Destination pathname (not used). */ + struct stat *sbPtr; /* Stat info for file specified by src. */ + int type; /* Reason for call - see TraverseUnixTree(). */ + Tcl_DString *errorPtr; /* If non-NULL, initialized DString for + * error return. */ +{ + switch (type) { + case DOTREE_F: + if (unlink(src) == 0) { + return TCL_OK; + } + break; + + case DOTREE_PRED: + return TCL_OK; + + case DOTREE_POSTD: + if (rmdir(src) == 0) { + return TCL_OK; + } + break; + + } + + if (errorPtr != NULL) { + Tcl_DStringAppend(errorPtr, src, -1); + } + 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) + char *src; /* Path name of source file */ + char *dst; /* Path name of target file */ + struct stat *statBufPtr; /* ptr to 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)) { + newMode &= ~(S_ISUID | S_ISGID); + if (chmod(dst, newMode)) { + return TCL_ERROR; + } + } + + tval.actime = statBufPtr->st_atime; + tval.modtime = statBufPtr->st_mtime; + + if (utime(dst, &tval)) { + 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. */ + char *fileName; /* The name of the file. */ + Tcl_Obj **attributePtrPtr; /* A pointer to return the object with. */ +{ + struct stat statBuf; + struct group *groupPtr; + + if (stat(fileName, &statBuf) != 0) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "could not stat file \"", fileName, "\": ", + Tcl_PosixError(interp), (char *) NULL); + return TCL_ERROR; + } + + groupPtr = getgrgid(statBuf.st_gid); + if (groupPtr == NULL) { + *attributePtrPtr = Tcl_NewIntObj(statBuf.st_gid); + } else { + *attributePtrPtr = Tcl_NewStringObj(groupPtr->gr_name, -1); + } + 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. */ + char *fileName; /* The name of the file. */ + Tcl_Obj **attributePtrPtr; /* A pointer to return the object with. */ +{ + struct stat statBuf; + struct passwd *pwPtr; + + if (stat(fileName, &statBuf) != 0) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "could not stat file \"", fileName, "\": ", + Tcl_PosixError(interp), (char *) NULL); + return TCL_ERROR; + } + + pwPtr = getpwuid(statBuf.st_uid); + if (pwPtr == NULL) { + *attributePtrPtr = Tcl_NewIntObj(statBuf.st_uid); + } else { + *attributePtrPtr = Tcl_NewStringObj(pwPtr->pw_name, -1); + } + 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. */ + char *fileName; /* The name of the file. */ + Tcl_Obj **attributePtrPtr; /* A pointer to return the object with. */ +{ + struct stat statBuf; + char returnString[6]; + + if (stat(fileName, &statBuf) != 0) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "could not stat file \"", 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 file to the given group. + * + * Results: + * Standard TCL result. + * + * Side effects: + * The group of the file is changed. + * + *---------------------------------------------------------------------- + */ + +static int +SetGroupAttribute(interp, objIndex, fileName, attributePtr) + Tcl_Interp *interp; /* The interp we are using for errors. */ + int objIndex; /* The index of the attribute. */ + char *fileName; /* The name of the file. */ + Tcl_Obj *attributePtr; /* The attribute to set. */ +{ + gid_t groupNumber; + long placeHolder; + + if (Tcl_GetLongFromObj(interp, attributePtr, &placeHolder) != TCL_OK) { + struct group *groupPtr; + char *groupString = Tcl_GetStringFromObj(attributePtr, NULL); + + Tcl_ResetResult(interp); + groupPtr = getgrnam(groupString); + if (groupPtr == NULL) { + endgrent(); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "could not set group for file \"", fileName, + "\": group \"", groupString, "\" does not exist", + (char *) NULL); + return TCL_ERROR; + } + groupNumber = groupPtr->gr_gid; + } else { + groupNumber = (gid_t) placeHolder; + } + + if (chown(fileName, -1, groupNumber) != 0) { + endgrent(); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "could not set group for file \"", fileName, "\": ", + Tcl_PosixError(interp), (char *) NULL); + return TCL_ERROR; + } + endgrent(); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * SetOwnerAttribute + * + * Sets the file to the given owner. + * + * Results: + * Standard TCL result. + * + * Side effects: + * The group of the file is changed. + * + *---------------------------------------------------------------------- + */ + +static int +SetOwnerAttribute(interp, objIndex, fileName, attributePtr) + Tcl_Interp *interp; /* The interp we are using for errors. */ + int objIndex; /* The index of the attribute. */ + char *fileName; /* The name of the file. */ + Tcl_Obj *attributePtr; /* The attribute to set. */ +{ + uid_t userNumber; + long placeHolder; + + if (Tcl_GetLongFromObj(interp, attributePtr, &placeHolder) != TCL_OK) { + struct passwd *pwPtr; + char *ownerString = Tcl_GetStringFromObj(attributePtr, NULL); + + Tcl_ResetResult(interp); + pwPtr = getpwnam(ownerString); + if (pwPtr == NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "could not set owner for file \"", fileName, + "\": user \"", ownerString, "\" does not exist", + (char *) NULL); + return TCL_ERROR; + } + userNumber = pwPtr->pw_uid; + } else { + userNumber = (uid_t) placeHolder; + } + + if (chown(fileName, userNumber, -1) != 0) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(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 group. + * + * Results: + * Standard TCL result. + * + * Side effects: + * The group 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. */ + char *fileName; /* The name of the file. */ + Tcl_Obj *attributePtr; /* The attribute to set. */ +{ + long modeInt; + mode_t newMode; + + /* + * mode_t is a long under SPARC; an int under SunOS. Since we do not + * know how big it really is, we get the long and then cast it + * down to a mode_t. + */ + + if (Tcl_GetLongFromObj(interp, attributePtr, &modeInt) + != TCL_OK) { + return TCL_ERROR; + } + + newMode = (mode_t) modeInt; + + if (chmod(fileName, newMode) != 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; +} + diff --git a/unix/tclUnixFile.c b/unix/tclUnixFile.c new file mode 100644 index 0000000..eb11006 --- /dev/null +++ b/unix/tclUnixFile.c @@ -0,0 +1,528 @@ +/* + * tclUnixFile.c -- + * + * This file contains wrappers around UNIX file handling functions. + * These wrappers mask differences between Windows and UNIX. + * + * 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. + * + * SCCS: @(#) tclUnixFile.c 1.48 97/07/07 16:38:11 + */ + +#include "tclInt.h" +#include "tclPort.h" + +/* + * The variable below caches the name of the current working directory + * in order to avoid repeated calls to getcwd. The string is malloc-ed. + * NULL means the cache needs to be refreshed. + */ + +static char *currentDir = NULL; +static int currentDirExitHandlerSet = 0; + +/* + * The variable below is set if the exit routine for deleting the string + * containing the executable name has been registered. + */ + +static int executableNameExitHandlerSet = 0; + +extern pid_t waitpid _ANSI_ARGS_((pid_t pid, int *stat_loc, int options)); + +/* + * Static routines for this file: + */ + +static void FreeCurrentDir _ANSI_ARGS_((ClientData clientData)); +static void FreeExecutableName _ANSI_ARGS_((ClientData clientData)); + +/* + *---------------------------------------------------------------------- + * + * FreeCurrentDir -- + * + * Frees the string stored in the currentDir variable. This routine + * is registered as an exit handler and will be called during shutdown. + * + * Results: + * None. + * + * Side effects: + * Frees the memory occuppied by the currentDir value. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static void +FreeCurrentDir(clientData) + ClientData clientData; /* Not used. */ +{ + if (currentDir != (char *) NULL) { + ckfree(currentDir); + currentDir = (char *) NULL; + currentDirExitHandlerSet = 0; + } +} + +/* + *---------------------------------------------------------------------- + * + * FreeExecutableName -- + * + * Frees the string stored in the tclExecutableName variable. This + * routine is registered as an exit handler and will be called + * during shutdown. + * + * Results: + * None. + * + * Side effects: + * Frees the memory occuppied by the tclExecutableName value. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static void +FreeExecutableName(clientData) + ClientData clientData; /* Not used. */ +{ + if (tclExecutableName != (char *) NULL) { + ckfree(tclExecutableName); + tclExecutableName = (char *) NULL; + } +} + +/* + *---------------------------------------------------------------------- + * + * TclChdir -- + * + * Change the current working directory. + * + * Results: + * The result is a standard Tcl result. If an error occurs and + * interp isn't NULL, an error message is left in interp->result. + * + * Side effects: + * The working directory for this application is changed. Also + * the cache maintained used by TclGetCwd is deallocated and + * set to NULL. + * + *---------------------------------------------------------------------- + */ + +int +TclChdir(interp, dirName) + Tcl_Interp *interp; /* If non NULL, used for error reporting. */ + char *dirName; /* Path to new working directory. */ +{ + if (currentDir != NULL) { + ckfree(currentDir); + currentDir = NULL; + } + if (chdir(dirName) != 0) { + if (interp != NULL) { + Tcl_AppendResult(interp, "couldn't change working directory to \"", + dirName, "\": ", Tcl_PosixError(interp), (char *) NULL); + } + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclGetCwd -- + * + * Return the path name of the current working directory. + * + * Results: + * The result is the full path name of the current working + * directory, or NULL if an error occurred while figuring it out. + * The returned string is owned by the TclGetCwd routine and must + * not be freed by the caller. If an error occurs and interp + * isn't NULL, an error message is left in interp->result. + * + * Side effects: + * The path name is cached to avoid having to recompute it + * on future calls; if it is already cached, the cached + * value is returned. + * + *---------------------------------------------------------------------- + */ + +char * +TclGetCwd(interp) + Tcl_Interp *interp; /* If non NULL, used for error reporting. */ +{ + char buffer[MAXPATHLEN+1]; + + if (currentDir == NULL) { + if (!currentDirExitHandlerSet) { + currentDirExitHandlerSet = 1; + Tcl_CreateExitHandler(FreeCurrentDir, (ClientData) NULL); + } +#ifdef USEGETWD + if ((int)getwd(buffer) == (int)NULL) { + if (interp != NULL) { + Tcl_AppendResult(interp, + "error getting working directory name: ", + buffer, (char *)NULL); + } + return NULL; + } +#else + if (getcwd(buffer, MAXPATHLEN+1) == NULL) { + if (interp != NULL) { + if (errno == ERANGE) { + Tcl_SetResult(interp, + "working directory name is too long", + TCL_STATIC); + } else { + Tcl_AppendResult(interp, + "error getting working directory name: ", + Tcl_PosixError(interp), (char *) NULL); + } + } + return NULL; + } +#endif + currentDir = (char *) ckalloc((unsigned) (strlen(buffer) + 1)); + strcpy(currentDir, buffer); + } + return currentDir; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_FindExecutable -- + * + * This procedure computes the absolute path name of the current + * application, given its argv[0] value. + * + * Results: + * None. + * + * Side effects: + * The variable tclExecutableName gets filled in with the file + * name for the application, if we figured it out. If we couldn't + * figure it out, Tcl_FindExecutable is set to NULL. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_FindExecutable(argv0) + char *argv0; /* The value of the application's argv[0]. */ +{ + char *name, *p, *cwd; + Tcl_DString buffer; + int length; + struct stat statBuf; + + Tcl_DStringInit(&buffer); + if (tclExecutableName != NULL) { + ckfree(tclExecutableName); + tclExecutableName = NULL; + } + + 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"); + if (p == NULL) { + /* + * There's no PATH environment variable; use the default that + * is used by sh. + */ + + p = ":/bin:/usr/bin"; + } + + /* + * 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 (*p != 0) { + while (isspace(UCHAR(*p))) { + 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); + } + } + Tcl_DStringAppend(&buffer, argv0, -1); + if ((access(Tcl_DStringValue(&buffer), X_OK) == 0) + && (stat(Tcl_DStringValue(&buffer), &statBuf) == 0) + && S_ISREG(statBuf.st_mode)) { + name = Tcl_DStringValue(&buffer); + goto gotName; + } + if (*p == 0) { + break; + } + p++; + } + goto done; + + /* + * If the name starts with "/" then just copy it to tclExecutableName. + */ + + gotName: + if (name[0] == '/') { + tclExecutableName = (char *) ckalloc((unsigned) (strlen(name) + 1)); + strcpy(tclExecutableName, name); + 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; + } + cwd = TclGetCwd((Tcl_Interp *) NULL); + if (cwd == NULL) { + tclExecutableName = NULL; + goto done; + } + length = strlen(cwd); + tclExecutableName = (char *) ckalloc((unsigned) + (length + strlen(name) + 2)); + strcpy(tclExecutableName, cwd); + tclExecutableName[length] = '/'; + strcpy(tclExecutableName + length + 1, name); + + done: + Tcl_DStringFree(&buffer); + + if (!executableNameExitHandlerSet) { + executableNameExitHandlerSet = 1; + Tcl_CreateExitHandler(FreeExecutableName, (ClientData) NULL); + } +} + +/* + *---------------------------------------------------------------------- + * + * TclGetUserHome -- + * + * This function takes the passed in user name and finds the + * corresponding home directory specified in the password file. + * + * Results: + * The result is a pointer to a static string containing + * the new name. If there was an error in processing the + * user name then the return value is NULL. Otherwise the + * result is stored in bufferPtr, and the caller must call + * Tcl_DStringFree(bufferPtr) to free the result. + * + * Side effects: + * Information may be left in bufferPtr. + * + *---------------------------------------------------------------------- + */ + +char * +TclGetUserHome(name, bufferPtr) + char *name; /* User name to use to find home directory. */ + Tcl_DString *bufferPtr; /* May be used to hold result. Must not hold + * anything at the time of the call, and need + * not even be initialized. */ +{ + struct passwd *pwPtr; + + pwPtr = getpwnam(name); + if (pwPtr == NULL) { + endpwent(); + return NULL; + } + Tcl_DStringInit(bufferPtr); + Tcl_DStringAppend(bufferPtr, pwPtr->pw_dir, -1); + endpwent(); + return bufferPtr->string; +} + +/* + *---------------------------------------------------------------------- + * + * TclMatchFiles -- + * + * 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 interp->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 +TclMatchFiles(interp, separators, dirPtr, pattern, tail) + Tcl_Interp *interp; /* Interpreter to receive results. */ + char *separators; /* Path 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. */ +{ + char *dirName, *patternEnd = tail; + char savedChar = 0; /* Initialization needed only to prevent + * compiler warning from gcc. */ + DIR *d; + struct stat statBuf; + struct dirent *entryPtr; + int matchHidden; + int result = TCL_OK; + int baseLength = Tcl_DStringLength(dirPtr); + + /* + * 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 (dirPtr->string[0] == '\0') { + dirName = "."; + } else { + dirName = dirPtr->string; + } + if ((stat(dirName, &statBuf) != 0) || !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. + */ + + d = opendir(dirName); + if (d == NULL) { + Tcl_ResetResult(interp); + + /* + * Strip off a trailing '/' if necessary, before reporting the error. + */ + + if (baseLength > 0) { + savedChar = dirPtr->string[baseLength-1]; + if (savedChar == '/') { + dirPtr->string[baseLength-1] = '\0'; + } + } + Tcl_AppendResult(interp, "couldn't read directory \"", + dirPtr->string, "\": ", Tcl_PosixError(interp), (char *) NULL); + if (baseLength > 0) { + dirPtr->string[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'; + + while (1) { + entryPtr = readdir(d); + if (entryPtr == NULL) { + break; + } + + /* + * Don't match names starting with "." unless the "." is + * present in the pattern. + */ + + if (!matchHidden && (*entryPtr->d_name == '.')) { + 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. + */ + + if (Tcl_StringMatch(entryPtr->d_name, pattern)) { + Tcl_DStringSetLength(dirPtr, baseLength); + Tcl_DStringAppend(dirPtr, entryPtr->d_name, -1); + if (tail == NULL) { + Tcl_AppendElement(interp, dirPtr->string); + } else if ((stat(dirPtr->string, &statBuf) == 0) + && S_ISDIR(statBuf.st_mode)) { + Tcl_DStringAppend(dirPtr, "/", 1); + result = TclDoGlob(interp, separators, dirPtr, tail); + if (result != TCL_OK) { + break; + } + } + } + } + *patternEnd = savedChar; + + closedir(d); + return result; +} diff --git a/unix/tclUnixInit.c b/unix/tclUnixInit.c new file mode 100644 index 0000000..91d866f --- /dev/null +++ b/unix/tclUnixInit.c @@ -0,0 +1,317 @@ +/* + * tclUnixInit.c -- + * + * Contains the Unix-specific interpreter initialization functions. + * + * Copyright (c) 1995-1996 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclUnixInit.c 1.26 97/08/05 20:09:25 + */ + +#include "tclInt.h" +#include "tclPort.h" +#if defined(__FreeBSD__) +# include <floatingpoint.h> +#endif +#if defined(__bsdi__) +# include <sys/param.h> +# if _BSDI_VERSION > 199501 +# include <dlfcn.h> +# endif +#endif + +/* + * Default directory in which to look for Tcl library scripts. The + * symbol is defined by Makefile. + */ + +static char defaultLibraryDir[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[200] = TCL_PACKAGE_PATH; + +/* + * Is this module initialized? + */ + +static int initialized = 0; + +/* + * The following string is the startup script executed in new + * interpreters. It looks on disk in several different directories + * for a script "init.tcl" that is compatible with this version + * of Tcl. The init.tcl script does all of the real work of + * initialization. + */ + +static char initScript[] = +"proc tclInit {} {\n\ + global tcl_library tcl_version tcl_patchLevel env errorInfo\n\ + global tcl_pkgPath\n\ + rename tclInit {}\n\ + set errors {}\n\ + set dirs {}\n\ + if [info exists env(TCL_LIBRARY)] {\n\ + lappend dirs $env(TCL_LIBRARY)\n\ + }\n\ + lappend dirs [info library]\n\ + set parentDir [file dirname [file dirname [info nameofexecutable]]]\n\ + lappend dirs $parentDir/lib/tcl$tcl_version\n\ + if [string match {*[ab]*} $tcl_patchLevel] {\n\ + set lib tcl$tcl_patchLevel\n\ + } else {\n\ + set lib tcl$tcl_version\n\ + }\n\ + lappend dirs [file dirname $parentDir]/$lib/library\n\ + lappend dirs $parentDir/library\n\ + foreach i $dirs {\n\ + set tcl_library $i\n\ + set tclfile [file join $i init.tcl]\n\ + if {[file exists $tclfile]} {\n\ + lappend tcl_pkgPath [file dirname $i]\n\ + if ![catch {uplevel #0 [list source $tclfile]} msg] {\n\ + return\n\ + } else {\n\ + append errors \"$tclfile: $msg\n$errorInfo\n\"\n\ + }\n\ + }\n\ + }\n\ + set msg \"Can't find a usable init.tcl in the following directories: \n\"\n\ + append msg \" $dirs\n\n\"\n\ + append msg \"$errors\n\n\"\n\ + append msg \"This probably means that Tcl wasn't installed properly.\n\"\n\ + error $msg\n\ +}\n\ +tclInit"; + +/* + * Static routines in this file: + */ + +static void PlatformInitExitHandler _ANSI_ARGS_((ClientData clientData)); + +/* + *---------------------------------------------------------------------- + * + * PlatformInitExitHandler -- + * + * Uninitializes all values on unload, so that this module can + * be later reinitialized. + * + * Results: + * None. + * + * Side effects: + * Returns the module to uninitialized state. + * + *---------------------------------------------------------------------- + */ + +static void +PlatformInitExitHandler(clientData) + ClientData clientData; /* Unused. */ +{ + strcpy(defaultLibraryDir, TCL_LIBRARY); + strcpy(pkgPath, TCL_PACKAGE_PATH); + initialized = 0; +} + +/* + *---------------------------------------------------------------------- + * + * TclPlatformInit -- + * + * Performs Unix-specific interpreter initialization related to the + * tcl_library and tcl_platform variables, and other platform- + * specific things. + * + * Results: + * None. + * + * Side effects: + * Sets "tcl_library" and "tcl_platform" Tcl variables. + * + *---------------------------------------------------------------------- + */ + +void +TclPlatformInit(interp) + Tcl_Interp *interp; +{ +#ifndef NO_UNAME + struct utsname name; +#endif + int unameOK; + + tclPlatform = TCL_PLATFORM_UNIX; + Tcl_SetVar(interp, "tcl_library", 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) { + unameOK = 1; + Tcl_SetVar2(interp, "tcl_platform", "os", name.sysname, + TCL_GLOBAL_ONLY); + /* + * 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(name.version[0])) { + 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); + } + + if (!initialized) { + + /* + * Create an exit handler so that uninitialization will be done + * on unload. + */ + + Tcl_CreateExitHandler(PlatformInitExitHandler, NULL); + + /* + * 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); +#endif + initialized = 1; + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_Init -- + * + * This procedure is typically invoked by Tcl_AppInit procedures + * to perform additional initialization for a Tcl interpreter, + * such as sourcing the "init.tcl" script. + * + * Results: + * Returns a standard Tcl completion code and sets interp->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. */ +{ + 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_Write(errChannel, interp->result, -1); + Tcl_Write(errChannel, "\n", 1); + } + } + } + } + Tcl_DStringFree(&temp); + } +} diff --git a/unix/tclUnixNotfy.c b/unix/tclUnixNotfy.c new file mode 100644 index 0000000..1a86680 --- /dev/null +++ b/unix/tclUnixNotfy.c @@ -0,0 +1,518 @@ +/* + * 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. + * + * SCCS: @(#) tclUnixNotfy.c 1.44 97/11/05 13:02:20 + */ + +#include "tclInt.h" +#include "tclPort.h" +#include <signal.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; /* 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. + */ + +static struct { + 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). */ +} notifier; + +/* + * The following static indicates whether this module has been initialized. + */ + +static int initialized = 0; + +/* + * Static routines defined in this file. + */ + +static void InitNotifier _ANSI_ARGS_((void)); +static void NotifierExitHandler _ANSI_ARGS_(( + ClientData clientData)); +static int FileHandlerEventProc _ANSI_ARGS_((Tcl_Event *evPtr, + int flags)); + +/* + *---------------------------------------------------------------------- + * + * InitNotifier -- + * + * Initializes the notifier state. + * + * Results: + * None. + * + * Side effects: + * Creates a new exit handler. + * + *---------------------------------------------------------------------- + */ + +static void +InitNotifier() +{ + 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 clientData; /* Not used. */ +{ + initialized = 0; +} + +/* + *---------------------------------------------------------------------- + * + * 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. + */ +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_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. + * + *---------------------------------------------------------------------- + */ + +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. */ +{ + FileHandler *filePtr; + int index, bit; + + if (!initialized) { + InitNotifier(); + } + + for (filePtr = notifier.firstFileHandlerPtr; filePtr != NULL; + filePtr = filePtr->nextPtr) { + if (filePtr->fd == fd) { + break; + } + } + if (filePtr == NULL) { + filePtr = (FileHandler*) ckalloc(sizeof(FileHandler)); /* MLK */ + filePtr->fd = fd; + filePtr->readyMask = 0; + filePtr->nextPtr = notifier.firstFileHandlerPtr; + notifier.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) { + notifier.checkMasks[index] |= bit; + } else { + notifier.checkMasks[index] &= ~bit; + } + if (mask & TCL_WRITABLE) { + (notifier.checkMasks+MASK_SIZE)[index] |= bit; + } else { + (notifier.checkMasks+MASK_SIZE)[index] &= ~bit; + } + if (mask & TCL_EXCEPTION) { + (notifier.checkMasks+2*(MASK_SIZE))[index] |= bit; + } else { + (notifier.checkMasks+2*(MASK_SIZE))[index] &= ~bit; + } + if (notifier.numFdBits <= fd) { + notifier.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; + + if (!initialized) { + InitNotifier(); + } + + /* + * 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; + } + } + + /* + * 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) { + notifier.checkMasks[index] &= ~bit; + } + if (filePtr->mask & TCL_WRITABLE) { + (notifier.checkMasks+MASK_SIZE)[index] &= ~bit; + } + if (filePtr->mask & TCL_EXCEPTION) { + (notifier.checkMasks+2*(MASK_SIZE))[index] &= ~bit; + } + + /* + * Find current max fd. + */ + + if (fd+1 == notifier.numFdBits) { + for (notifier.numFdBits = 0; index >= 0; index--) { + flags = notifier.checkMasks[index] + | (notifier.checkMasks+MASK_SIZE)[index] + | (notifier.checkMasks+2*(MASK_SIZE))[index]; + if (flags) { + for (i = (NBBY*sizeof(fd_mask)); i > 0; i--) { + if (flags & (((unsigned long)1) << (i-1))) { + break; + } + } + notifier.numFdBits = index * (NBBY*sizeof(fd_mask)) + i; + break; + } + } + } + + /* + * Clean up information in the callback record. + */ + + if (prevPtr == NULL) { + notifier.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. */ +{ + 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; +} + +/* + *---------------------------------------------------------------------- + * + * 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, numFound; + + if (!initialized) { + InitNotifier(); + } + + /* + * 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; + } else if (notifier.numFdBits == 0) { + return -1; + } else { + timeoutPtr = NULL; + } + + memcpy((VOID *) notifier.readyMasks, (VOID *) notifier.checkMasks, + 3*MASK_SIZE*sizeof(fd_mask)); + numFound = select(notifier.numFdBits, + (SELECT_MASK *) ¬ifier.readyMasks[0], + (SELECT_MASK *) ¬ifier.readyMasks[MASK_SIZE], + (SELECT_MASK *) ¬ifier.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 *) notifier.readyMasks, 0, 3*MASK_SIZE*sizeof(fd_mask)); + } + + /* + * Queue all detected file events before returning. + */ + + for (filePtr = notifier.firstFileHandlerPtr; + (filePtr != NULL) && (numFound > 0); + filePtr = filePtr->nextPtr) { + index = filePtr->fd / (NBBY*sizeof(fd_mask)); + bit = 1 << (filePtr->fd % (NBBY*sizeof(fd_mask))); + mask = 0; + + if (notifier.readyMasks[index] & bit) { + mask |= TCL_READABLE; + } + if ((notifier.readyMasks+MASK_SIZE)[index] & bit) { + mask |= TCL_WRITABLE; + } + if ((notifier.readyMasks+2*(MASK_SIZE))[index] & bit) { + mask |= TCL_EXCEPTION; + } + + if (!mask) { + continue; + } else { + numFound--; + } + + /* + * 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; + } + return 0; +} diff --git a/unix/tclUnixPipe.c b/unix/tclUnixPipe.c new file mode 100644 index 0000000..83aa4e8 --- /dev/null +++ b/unix/tclUnixPipe.c @@ -0,0 +1,1149 @@ +/* + * 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. + * + * SCCS: @(#) tclUnixPipe.c 1.37 97/10/31 17:23:37 + */ + +#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) + char *fname; /* The name of the file to open. */ + int mode; /* In what mode to open the file? */ +{ + int fd; + + fd = open(fname, mode, 0666); + 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, 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, namePtr) + char *contents; /* String to write into temp file, or NULL. */ + Tcl_DString *namePtr; /* If non-NULL, pointer to initialized + * DString that is filled with the name of + * the temp file that was created. */ +{ + char fileName[L_tmpnam]; + TclFile file; + size_t length = (contents == NULL) ? 0 : strlen(contents); + + tmpnam(fileName); + file = TclpOpenFile(fileName, O_RDWR|O_CREAT|O_TRUNC); + unlink(fileName); + + if ((file != NULL) && (length > 0)) { + int fd = GetFd(file); + while (1) { + if (write(fd, contents, length) != -1) { + break; + } else if (errno != EINTR) { + close(fd); + return NULL; + } + } + lseek(fd, 0, SEEK_SET); + } + if (namePtr != NULL) { + Tcl_DStringAppend(namePtr, fileName, -1); + } + return file; +} + +/* + *---------------------------------------------------------------------- + * + * 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 + * interp->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. argv[0] + * contains the name of the executable + * converted to native format (using the + * Tcl_TranslateFileName call). Additional + * arguments have not been converted. */ + TclFile inputFile; /* If non-NULL, gives the file to use as + * input for the child process. If inputFile + * file is not readable or is NULL, the child + * will receive no standard input. */ + TclFile outputFile; /* If non-NULL, gives the file that + * receives output from the child process. If + * outputFile file is not writeable or is + * NULL, output from the child will be + * discarded. */ + TclFile errorFile; /* If non-NULL, gives the file that + * receives errors from the child process. If + * errorFile file is not writeable or is NULL, + * errors from the child will be discarded. + * errorFile may be the same as outputFile. */ + Tcl_Pid *pidPtr; /* If this procedure is successful, pidPtr + * is filled with the process id of the child + * process. */ +{ + TclFile errPipeIn, errPipeOut; + int joinThisError, count, status, fd; + char errSpace[200]; + int pid; + + 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; + } + + joinThisError = (errorFile == outputFile); + pid = vfork(); + 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(argv[0], &argv[0]); + sprintf(errSpace, "%dcouldn't execute \"%.150s\": ", errno, + argv[0]); + write(fd, errSpace, (size_t) strlen(errSpace)); + _exit(1); + } + 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[20]; + 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 interp->result and to detach the processes. + * + * Results: + * None. + * + * Side effects: + * Modifies interp->result. Detaches processes. + * + *---------------------------------------------------------------------- + */ + +void +TclGetAndDetachPids(interp, chan) + Tcl_Interp *interp; + Tcl_Channel chan; +{ + PipeState *pipePtr; + Tcl_ChannelType *chanTypePtr; + int i; + char buf[20]; + + /* + * 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++) { + sprintf(buf, "%ld", 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; + } + curStatus = fcntl(fd, F_GETFL); + } + 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 */ + + 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_GetStringFromObj(objv[1], NULL), + 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 new file mode 100644 index 0000000..186de21 --- /dev/null +++ b/unix/tclUnixPort.h @@ -0,0 +1,480 @@ +/* + * 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-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. + * + * SCCS: @(#) tclUnixPort.h 1.49 97/07/30 14:11:59 + */ + +#ifndef _TCLUNIXPORT +#define _TCLUNIXPORT + +#ifndef _TCLINT +# include "tclInt.h" +#endif +#include <errno.h> +#include <fcntl.h> +#ifdef HAVE_NET_ERRNO_H +# include <net/errno.h> +#endif +#include <pwd.h> +#include <signal.h> +#include <sys/param.h> +#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 */ + +/* + * 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 following defines denote malloc and free as the system calls + * used to allocate new memory. These defines are only used in the + * file tclCkalloc.c. + */ + +#define TclpAlloc(size) malloc(size) +#define TclpFree(ptr) free(ptr) +#define TclpRealloc(ptr, size) realloc(ptr, size) + +/* + * The default platform eol translation on Unix is TCL_TRANSLATE_LF: + */ + +#define TCL_PLATFORM_TRANSLATION TCL_TRANSLATE_LF + +/* + * 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; + +/* + * 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) + +/* + * The following implements the Unix method for exiting the process. + */ +#define TclPlatformExit(status) exit(status) + +/* + * The following functions always succeeds under Unix. + */ + +#define TclHasSockets(interp) (TCL_OK) +#define TclHasPipes() (1) + +/* + * Variables provided by the C library: + */ + +#if defined(_sgi) || defined(__sgi) +#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 define time related functions in terms of + * standard Unix routines. + */ + +#define TclpGetDate(t,u) ((u) ? gmtime((t)) : localtime((t))) +#define TclStrftime(s,m,f,t) (strftime((s),(m),(f),(t))) +#define TclpGetPid(pid) ((unsigned long) (pid)) + +#define TclpReleaseFile(file) + +/* + * The following routine is only exported for testing purposes. + */ + +EXTERN int TclUnixWaitForFile _ANSI_ARGS_((int fd, int mask, + int timeout)); + +#endif /* _TCLUNIXPORT */ diff --git a/unix/tclUnixSock.c b/unix/tclUnixSock.c new file mode 100644 index 0000000..c532993 --- /dev/null +++ b/unix/tclUnixSock.c @@ -0,0 +1,100 @@ +/* + * 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. + * + * SCCS: @(#) tclUnixSock.c 1.9 97/10/09 18:24:49 + */ + +#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_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; +#endif + + if (hostnameInited) { + return hostname; + } + +#ifndef NO_UNAME + (VOID *) memset((VOID *) &u, (int) 0, sizeof(struct utsname)); + if (uname(&u) > -1) { + hp = gethostbyname(u.nodename); + if (hp != NULL) { + strcpy(hostname, hp->h_name); + } else { + strcpy(hostname, u.nodename); + } + hostnameInited = 1; + return hostname; + } +#else + /* + * Uname doesn't exist; try gethostname instead. + */ + + if (gethostname(hostname, sizeof(hostname)) > -1) { + hostnameInited = 1; + return hostname; + } +#endif + + hostname[0] = 0; + return hostname; +} diff --git a/unix/tclUnixTest.c b/unix/tclUnixTest.c new file mode 100644 index 0000000..b1d1676 --- /dev/null +++ b/unix/tclUnixTest.c @@ -0,0 +1,431 @@ +/* + * tclUnixTest.c -- + * + * Contains platform specific test commands for the Unix platform. + * + * Copyright (c) 1996 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclUnixTest.c 1.5 97/10/31 17:23:42 + */ + +#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. 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]; + +/* + * 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 TestgetopenfileCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +int TclplatformtestInit _ANSI_ARGS_((Tcl_Interp *interp)); + +/* + *---------------------------------------------------------------------- + * + * 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, "testgetopenfile", TestgetopenfileCmd, + (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[30]; + + 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[30]; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # arguments: should be \"", + argv[0], " empty index\"", (char *) NULL); + return TCL_ERROR; + } + + memset((VOID *) buffer, 'b', 10); + sprintf(buf, "%d", 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; +} + +/* + *---------------------------------------------------------------------- + * + * 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; +} diff --git a/unix/tclUnixTime.c b/unix/tclUnixTime.c new file mode 100644 index 0000000..ba8d984 --- /dev/null +++ b/unix/tclUnixTime.c @@ -0,0 +1,236 @@ +/* + * 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. + * + * SCCS: @(#) tclUnixTime.c 1.13 97/10/31 15:04:58 + */ + +#include "tclInt.h" +#include "tclPort.h" + +/* + *----------------------------------------------------------------------------- + * + * 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; + int timeZone; + + if (!setTZ) { + tzset(); + setTZ = 1; + } + + /* + * 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; +} diff --git a/unix/tclXtTest.c b/unix/tclXtTest.c new file mode 100644 index 0000000..1479412 --- /dev/null +++ b/unix/tclXtTest.c @@ -0,0 +1,113 @@ +/* + * 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. + * + * SCCS: @(#) tclXtTest.c 1.2 97/09/15 15:26:52 + */ + +#include <X11/Intrinsic.h> +#include "tcl.h" + +static int TesteventloopCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); + +/* + *---------------------------------------------------------------------- + * + * 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 interp->result if an error occurs. + * + * Side effects: + * Depends on the startup script. + * + *---------------------------------------------------------------------- + */ + +int +Tclxttest_Init(interp) + Tcl_Interp *interp; /* Interpreter for application. */ +{ + 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; +} |