diff options
| author | phk <phk@FreeBSD.org> | 1997-07-25 19:27:55 +0000 |
|---|---|---|
| committer | phk <phk@FreeBSD.org> | 1997-07-25 19:27:55 +0000 |
| commit | cd0c23d19a3bde32cd2e62400904f9074c24db05 (patch) | |
| tree | d153c63214704ab74e436104a9040c8ba458a780 /contrib/tcl/unix | |
| parent | e09ba6062a66b9b7a050cd033026be349cbd873c (diff) | |
| parent | 30db38624722a51670556ef9b2dd7ccf4fb57387 (diff) | |
| download | FreeBSD-src-cd0c23d19a3bde32cd2e62400904f9074c24db05.zip FreeBSD-src-cd0c23d19a3bde32cd2e62400904f9074c24db05.tar.gz | |
This commit was generated by cvs2svn to compensate for changes in r27676,
which included commits to RCS files with non-trunk default branches.
Diffstat (limited to 'contrib/tcl/unix')
26 files changed, 5438 insertions, 1712 deletions
diff --git a/contrib/tcl/unix/Makefile.in b/contrib/tcl/unix/Makefile.in index 79f4359..3d992a1 100644 --- a/contrib/tcl/unix/Makefile.in +++ b/contrib/tcl/unix/Makefile.in @@ -5,7 +5,7 @@ # "autoconf" program (constructs like "@foo@" will get replaced in the # actual Makefile. # -# SCCS: @(#) Makefile.in 1.140 96/08/01 20:06:06 +# SCCS: @(#) Makefile.in 1.174 97/06/26 17:58:32 # Current Tcl version; used in various names. @@ -39,6 +39,9 @@ INSTALL_ROOT = # 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) @@ -101,10 +104,12 @@ ENV_FLAGS = # the current one does). GENERIC_FLAGS = #GENERIC_FLAGS = -DTCL_GENERIC_ONLY -UNIX_OBJS = tclMtherr.o tclUnixChan.o tclUnixFile.o \ - tclUnixNotfy.o tclUnixPipe.o tclUnixSock.o tclUnixTime.o \ - tclUnixInit.o +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 @@ -113,6 +118,12 @@ UNIX_OBJS = tclMtherr.o tclUnixChan.o tclUnixFile.o \ 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 @@ -171,6 +182,7 @@ 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@ @@ -184,7 +196,7 @@ CC = @CC@ CC_SWITCHES = ${CFLAGS} ${TCL_SHLIB_CFLAGS} -I${GENERIC_DIR} -I${SRC_DIR} \ ${AC_FLAGS} ${MATH_FLAGS} ${GENERIC_FLAGS} ${PROTO_FLAGS} ${MEM_DEBUG_FLAGS} \ -${ENV_FLAGS} -DTCL_SHLIB_EXT=\"${SHLIB_SUFFIX}\" +${COMPILE_DEBUG_FLAGS} ${ENV_FLAGS} -DTCL_SHLIB_EXT=\"${SHLIB_SUFFIX}\" LIBS = @DL_LIBS@ @LIBS@ $(MATH_LIBS) -lc @@ -195,58 +207,73 @@ ${GENERIC_FLAGS} ${PROTO_FLAGS} ${MEM_DEBUG_FLAGS} \ TCLSH_OBJS = tclAppInit.o -TCLTEST_OBJS = tclTestInit.o tclTest.o tclUnixTest.o +TCLTEST_OBJS = tclTestInit.o tclTest.o tclTestObj.o tclUnixTest.o -GENERIC_OBJS = panic.o regexp.o tclAsync.o tclBasic.o tclCkalloc.o \ - tclClock.o tclCmdAH.o tclCmdIL.o tclCmdMZ.o tclDate.o tclEnv.o \ - tclEvent.o tclExpr.o tclFHandle.o tclFileName.o tclGet.o tclHash.o \ - tclHistory.o tclInterp.o tclIO.o tclIOCmd.o \ - tclIOSock.o tclIOUtil.o tclLink.o tclLoad.o tclMain.o tclNotify.o \ - tclParse.o tclPkg.o tclPosixStr.o tclPreserve.o tclProc.o \ - tclUtil.o tclVar.o +XTTEST_OBJS = tclTest.o tclTestObj.o tclUnixTest.o tclXtNotify.o \ + tclXtTest.o xtTestInit.o -OBJS = ${GENERIC_OBJS} ${UNIX_OBJS} ${COMPAT_OBJS} @DL_OBJS@ +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)/patchlevel.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)/tclExpr.c \ - $(GENERIC_DIR)/tclFHandle.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)/tclParse.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 @@ -257,6 +284,8 @@ 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 \ @@ -299,6 +328,13 @@ 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. @@ -311,6 +347,8 @@ test: 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: @@ -341,8 +379,8 @@ gendate: # 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 + 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 @@ -376,7 +414,7 @@ install-binaries: $(TCL_LIB_FILE) tclsh install-libraries: @for i in $(INSTALL_ROOT)$(prefix)/lib $(INCLUDE_INSTALL_DIR) \ - $(SCRIPT_INSTALL_DIR) ; \ + $(SCRIPT_INSTALL_DIR); \ do \ if [ ! -d $$i ] ; then \ echo "Making directory $$i"; \ @@ -385,13 +423,30 @@ install-libraries: else true; \ fi; \ done; + @for i in http1.0 ; \ + 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; \ + @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 http1.0 ; \ + 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) ; \ @@ -437,11 +492,12 @@ Makefile: $(UNIX_DIR)/Makefile.in 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 + if test -f dltest/Makefile; then cd dltest; $(MAKE) clean; fi distclean: clean - rm -f Makefile config.status config.cache config.log tclConfig.sh - if test -f dltest/Makefile; then cd dltest; make distclean; fi + 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) @@ -449,9 +505,10 @@ depend: bp: $(UNIX_DIR)/bp.c $(CC) $(CC_SWITCHES) $(UNIX_DIR)/bp.c -o bp -# Test binaries. The rule for tclTestInit.o is complicated because -# it is is compiled from tclAppInit.c. Can't use the "-o" option -# because this doesn't work on some strange compilers (e.g. UnixWare). +# 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 \ @@ -465,6 +522,19 @@ tclTestInit.o: $(UNIX_DIR)/tclAppInit.c 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 @@ -482,6 +552,9 @@ tclAsync.o: $(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 @@ -500,17 +573,23 @@ tclCmdMZ.o: $(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 -tclExpr.o: $(GENERIC_DIR)/tclExpr.c - $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclExpr.c +tclExecute.o: $(GENERIC_DIR)/tclExecute.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclExecute.c -tclFHandle.o: $(GENERIC_DIR)/tclFHandle.c - $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclFHandle.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 @@ -524,6 +603,9 @@ tclHash.o: $(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 @@ -542,6 +624,12 @@ tclIOUtil.o: $(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 @@ -575,12 +663,18 @@ tclMain.o: $(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 @@ -593,6 +687,9 @@ tclPreserve.o: $(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 @@ -602,9 +699,21 @@ tclVar.o: $(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 @@ -625,6 +734,7 @@ tclUnixTime.o: $(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 @@ -683,74 +793,181 @@ checkexports: $(TCL_LIB_FILE) # to put the distribution. # -DISTDIR = /proj/tcl/dist/tcl7.5p1 -configure: configure.in - autoconf -dist: configure +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 - cp Makefile.in $(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 configure configure.in tclConfig.sh.in install-sh porting.notes \ - porting.old README ldAix $(DISTDIR)/unix + 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 mkLinks.tcl ../doc/*.[13n] > $(DISTDIR)/unix/mkLinks + 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 ../changes ../README ../license.terms $(DISTDIR) + cp -p $(TOP_DIR)/changes $(TOP_DIR)/README $(TOP_DIR)/license.terms \ + $(DISTDIR) mkdir $(DISTDIR)/library - cp -p ../license.terms ../library/*.tcl ../library/tclIndex \ - $(DISTDIR)/library + cp -p $(TOP_DIR)/license.terms $(TOP_DIR)/library/*.tcl \ + $(TOP_DIR)/library/tclIndex $(DISTDIR)/library + for i in http1.0; \ + do \ + mkdir $(DISTDIR)/library/$$i ;\ + cp -p $(TOP_DIR)/library/$$i/*.tcl $(DISTDIR)/library/$$i; \ + done; mkdir $(DISTDIR)/doc - cp -p ../license.terms ../doc/*.[13n] ../doc/man.macros $(DISTDIR)/doc + cp -p $(TOP_DIR)/license.terms $(TOP_DIR)/doc/*.[13n] \ + $(TOP_DIR)/doc/man.macros $(DISTDIR)/doc mkdir $(DISTDIR)/compat - cp -p ../license.terms ../compat/*.c ../compat/*.h ../compat/README \ + 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 ../license.terms $(DISTDIR)/tests - cp -p ../tests/*.test ../tests/README ../tests/all \ - ../tests/remote.tcl ../tests/defs $(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 + cp -r -p $(TOP_DIR)/tests/policies $(DISTDIR)/tests/policies + find $(DISTDIR)/tests/policies -name SCCS -exec rm -rf {} \; mkdir $(DISTDIR)/win - cp -p ../win/*.c ../win/*.h ../win/*.rc $(DISTDIR)/win - cp -p ../win/makefile.* $(DISTDIR)/win - cp -p ../win/README $(DISTDIR)/win - cp -p ../license.terms $(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 ../mac/tclMacProjects.sit.hqx + sccs edit -s $(TOP_DIR)/mac/tclMacProjects.sit.hqx cp -p tclMacProjects.sit.hqx $(DISTDIR)/mac - sccs unedit ../mac/tclMacProjects.sit.hqx + sccs unedit $(TOP_DIR)/mac/tclMacProjects.sit.hqx rm -f tclMacProjects.sit.hqx - cp -p ../mac/*.c ../mac/*.h ../mac/*.r $(DISTDIR)/mac - cp -p ../mac/porting.notes ../mac/README $(DISTDIR)/mac - cp -p ../mac/*.doc ../mac/*.pch $(DISTDIR)/mac - cp -p ../license.terms $(DISTDIR)/mac + cp -p $(TOP_DIR)/mac/*.c $(TOP_DIR)/mac/*.h $(TOP_DIR)/mac/*.r \ + $(DISTDIR)/mac + cp -p $(TOP_DIR)/mac/porting.notes $(TOP_DIR)/mac/README $(DISTDIR)/mac + cp -p $(TOP_DIR)/mac/*.exp $(TOP_DIR)/mac/*.pch $(DISTDIR)/mac + cp -p $(TOP_DIR)/mac/*.doc $(DISTDIR)/mac + cp -p $(TOP_DIR)/license.terms $(DISTDIR)/mac mkdir $(DISTDIR)/unix/dltest - cp -p dltest/*.c dltest/Makefile.in $(DISTDIR)/unix/dltest - cp -p dltest/configure.in dltest/configure $(DISTDIR)/unix/dltest - cp -p dltest/README $(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 + +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 -c $(DISTNAME).tar > $(DISTNAME).tar.gz; \ + compress $(DISTNAME).tar; zip -r8 $(ZIPNAME) $(DISTNAME) # # 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 greoup's tool workspace. +# programs found only in the Tcl group's tool workspace. # -TOOLDIR = /home/rjohnson/Projects/tools macdist: dist rm -f $(DISTDIR)/mac/tclMacProjects.sit.hqx - tclsh $(TOOLDIR)/generic/man2html.tcl $(DISTDIR)/tmp ../.. tcl$(VERSION) + 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 $(TOOLDIR)/mac/cvtEOL.tcl $(DISTDIR) + 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/contrib/tcl/unix/README b/contrib/tcl/unix/README index 9d950e8..96c79c1 100644 --- a/contrib/tcl/unix/README +++ b/contrib/tcl/unix/README @@ -12,7 +12,7 @@ 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.13 96/07/31 16:28:38 +SCCS: @(#) README 1.15 96/12/19 14:02:23 How To Compile And Install Tcl: ------------------------------- @@ -75,15 +75,15 @@ How To Compile And Install Tcl: 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 "tclsh7.5" or "libtcl7.5.so"; + 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 "tclsh7.5"). + 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.4.1 + 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 diff --git a/contrib/tcl/unix/configure.in b/contrib/tcl/unix/configure.in index 408c4f9..61605dc 100755 --- a/contrib/tcl/unix/configure.in +++ b/contrib/tcl/unix/configure.in @@ -2,11 +2,12 @@ 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.107 96/07/30 08:38:37 +# SCCS: @(#) configure.in 1.135 97/06/10 17:28:19 -TCL_VERSION=7.5 -TCL_MAJOR_VERSION=7 -TCL_MINOR_VERSION=5 +TCL_VERSION=8.0 +TCL_MAJOR_VERSION=8 +TCL_MINOR_VERSION=0 +TCL_PATCH_LEVEL=b2 VERSION=${TCL_VERSION} if test "${prefix}" = "NONE"; then @@ -15,6 +16,7 @@ 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], @@ -50,6 +52,21 @@ 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 @@ -85,6 +102,7 @@ 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) @@ -100,8 +118,67 @@ 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. @@ -138,26 +215,52 @@ 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_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)) + AC_MSG_RESULT(no)) # # Its important to include time.h in this check, as some systems (like convex) # have timezone functions, etc. # -AC_MSG_CHECKING([timezone variable]) +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)) + 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 #-------------------------------------------------------------------- # On some systems strstr is broken: it returns a pointer even @@ -239,17 +342,17 @@ 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) +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 @@ -326,30 +429,30 @@ 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) +#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 @@ -406,6 +509,23 @@ 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 @@ -473,7 +593,7 @@ AC_CHECK_FUNC(gethostbyname, , AC_CHECK_LIB(nsl, main, [LIBS="$LIBS -lnsl"])) # 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.5.so or libtcl7.5.a. +# 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 @@ -517,22 +637,25 @@ fi AC_CHECK_LIB(dl, dlopen, have_dl=yes, have_dl=no) -# Step 3: 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 - system=unknown -fi - -# Step 4: set configuration options based on system name and version. +# Step 3: set configuration options based on system name and version. fullSrcDir=`cd $srcdir; pwd` -AIX=no 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" + 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" @@ -542,14 +665,22 @@ case $system in DL_LIBS="-lld" LD_FLAGS="" LD_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}' - AC_DEFINE(NO_DLFCN_H) - AIX=yes TCL_SHARED_LIB_SUFFIX='${VERSION}.a' ;; - BSD/OS-2.1*) + BSD/OS-2.1*|BSD/OS-3*) SHLIB_CFLAGS="" - SHLIB_LD="ld -r" - SHLIB_LD_FLAGS="" + 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" @@ -557,24 +688,28 @@ case $system in LD_SEARCH_FLAGS="" ;; HP-UX-*.08.*|HP-UX-*.09.*|HP-UX-*.10.*) - SHLIB_CFLAGS="+z" - SHLIB_LD="ld -b" - SHLIB_LD_LIBS='${LIBS}' - SHLIB_SUFFIX=".sl" - DL_OBJS="tclLoadShl.o" - DL_LIBS="-ldld" - LD_FLAGS="-Wl,-E" - LD_SEARCH_FLAGS='-Wl,+b,${LIB_RUNTIME_DIR}:.' + 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="..o" + SHLIB_SUFFIX=".a" SHLIB_LD="echo tclLdAout $CC \{$SHLIB_CFLAGS\} | `pwd`/tclsh -r -G 0" - SHLIB_LD_LIBS="" + SHLIB_LD_LIBS='${LIBS}' DL_OBJS="tclLoadAout.o" DL_LIBS="" LD_FLAGS="-Wl,-D,08000000" - LD_SEARCH_FLAGS="" + LD_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}' + TCL_SHARED_LIB_SUFFIX='${VERSION}.a' ;; IRIX-5.*|IRIX-6.*) SHLIB_CFLAGS="" @@ -635,32 +770,32 @@ case $system in LD_FLAGS="-Wl,-Bexport" LD_SEARCH_FLAGS="" ;; - NetBSD-*|FreeBSD-*) + NetBSD-*|FreeBSD-*|OpenBSD-*) # Not available on all versions: check for include file. AC_CHECK_HEADER(dlfcn.h, [ SHLIB_CFLAGS="-fpic" - SHLIB_LD="ld -Bshareable" + SHLIB_LD="ld -Bshareable -x" SHLIB_LD_LIBS="" SHLIB_SUFFIX=".so" - DL_OBJS="tclLoadDl2.o" + 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 -G 0" - SHLIB_LD_LIBS="" - SHLIB_SUFFIX="..o" + 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="" + LD_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}' + TCL_SHARED_LIB_SUFFIX='`echo ${VERSION} | tr -d .`.a' ]) - # FreeBSD doesn't handle version numbers with dots. Also, have to - # append a dummy version number to .so file names. + # FreeBSD doesn't handle version numbers with dots. - 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 ;; @@ -674,7 +809,7 @@ case $system in LD_FLAGS="" LD_SEARCH_FLAGS="" ;; - OSF1-1.[012]) + 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 @@ -711,12 +846,12 @@ case $system in RISCos-*) SHLIB_CFLAGS="-G 0" SHLIB_LD="echo tclLdAout $CC \{$SHLIB_CFLAGS\} | `pwd`/tclsh -r -G 0" - SHLIB_LD_LIBS="" - SHLIB_SUFFIX="..o" + SHLIB_LD_LIBS='${LIBS}' + SHLIB_SUFFIX=".a" DL_OBJS="tclLoadAout.o" DL_LIBS="" LD_FLAGS="-Wl,-D,08000000" - LD_SEARCH_FLAGS="" + LD_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}' ;; SCO_SV-3.2*) # Note, dlopen is available only on SCO 3.2.5 and greater. However, @@ -763,6 +898,10 @@ case $system in 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" @@ -772,13 +911,13 @@ case $system in ;; ULTRIX-4.*) SHLIB_CFLAGS="-G 0" - SHLIB_SUFFIX="..o" + SHLIB_SUFFIX=".a" SHLIB_LD="echo tclLdAout $CC \{$SHLIB_CFLAGS\} | `pwd`/tclsh -r -G 0" - SHLIB_LD_LIBS="" + SHLIB_LD_LIBS='${LIBS}' DL_OBJS="tclLoadAout.o" DL_LIBS="" LD_FLAGS="-Wl,-D,08000000" - LD_SEARCH_FLAGS="" + LD_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}' ;; UNIX_SV*) SHLIB_CFLAGS="-KPIC" @@ -787,17 +926,30 @@ case $system in SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="-ldl" - LD_FLAGS="-Wl,-Bexport" + # 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 -# 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, +# 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 @@ -868,6 +1020,14 @@ if test "x$DL_OBJS" = "xtclLoadAout.o" ; then 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 @@ -889,11 +1049,78 @@ fi if test "$DL_OBJS" != "tclLoadNone.o" ; then if test "$CC" = "gcc" -o `$CC -v 2>&1 | grep -c gcc` != "0" ; then - SHLIB_CFLAGS="-fPIC" + 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. #-------------------------------------------------------------------- @@ -908,17 +1135,28 @@ 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}" != "" \ - -a "${DL_OBJS}" != "tclLoadAout.o" ; then +if test "$tcl_ok" = "yes" -a "${SHLIB_SUFFIX}" != "" ; then TCL_SHLIB_CFLAGS="${SHLIB_CFLAGS}" TCL_LD_SEARCH_FLAGS="${LD_SEARCH_FLAGS}" eval "TCL_LIB_FILE=libtcl${TCL_SHARED_LIB_SUFFIX}" - MAKE_LIB="\${SHLIB_LD} -o ${TCL_LIB_FILE} \${OBJS} ${SHLIB_LD_LIBS}" - RANLIB=":" -else - if test "$AIX" = "no" ; then - SHLIB_LD_LIBS="" + if test "x$DL_OBJS" = "xtclLoadAout.o"; then + MAKE_LIB="ar cr ${TCL_LIB_FILE} \${OBJS}" + else + MAKE_LIB="\${SHLIB_LD} -o ${TCL_LIB_FILE} \${OBJS} ${SHLIB_LD_LIBS}" + RANLIB=":" fi +else + case $system in + BSD/OS*) + ;; + + AIX-*) + ;; + + *) + SHLIB_LD_LIBS="" + ;; + esac TCL_SHLIB_CFLAGS="" TCL_LD_SEARCH_FLAGS="" eval "TCL_LIB_FILE=libtcl${TCL_UNSHARED_LIB_SUFFIX}" @@ -938,6 +1176,19 @@ else 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) @@ -955,8 +1206,11 @@ AC_SUBST(TCL_LIB_SPEC) AC_SUBST(TCL_LIB_VERSIONS_OK) AC_SUBST(TCL_MAJOR_VERSION) AC_SUBST(TCL_MINOR_VERSION) +AC_SUBST(TCL_PACKAGE_PATH) +AC_SUBST(TCL_PATCH_LEVEL) AC_SUBST(TCL_SHARED_LIB_SUFFIX) AC_SUBST(TCL_SHLIB_CFLAGS) +AC_SUBST(TCL_SRC_DIR) AC_SUBST(TCL_UNSHARED_LIB_SUFFIX) AC_SUBST(TCL_VERSION) diff --git a/contrib/tcl/unix/dltest/Makefile.in b/contrib/tcl/unix/dltest/Makefile.in index 130ea18..2197b4b 100644 --- a/contrib/tcl/unix/dltest/Makefile.in +++ b/contrib/tcl/unix/dltest/Makefile.in @@ -1,7 +1,7 @@ # 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.11 96/04/15 09:50:19 +# SCCS: @(#) Makefile.in 1.12 97/02/22 14:13:54 CC = @CC@ LIBS = @TCL_BUILD_LIB_SPEC@ @TCL_LIBS@ -lc @@ -20,23 +20,23 @@ all: pkga${SHLIB_SUFFIX} pkgb${SHLIB_SUFFIX} pkgc${SHLIB_SUFFIX} pkgd${SHLIB_SUF pkga${SHLIB_SUFFIX}: $(SRC_DIR)/pkga.c $(CC) -c $(CC_SWITCHES) $(SRC_DIR)/pkga.c - ${SHLIB_LD} pkga.o -o pkga${SHLIB_SUFFIX} @SHLIB_LD_LIBS@ + ${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} pkgb.o -o pkgb${SHLIB_SUFFIX} @SHLIB_LD_LIBS@ + ${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} pkgc.o -o pkgc${SHLIB_SUFFIX} @SHLIB_LD_LIBS@ + ${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} pkgd.o -o pkgd${SHLIB_SUFFIX} @SHLIB_LD_LIBS@ + ${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} pkge.o -o pkge${SHLIB_SUFFIX} @SHLIB_LD_LIBS@ + ${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 diff --git a/contrib/tcl/unix/dltest/configure b/contrib/tcl/unix/dltest/configure index 219d63d..fa1663c 100755 --- a/contrib/tcl/unix/dltest/configure +++ b/contrib/tcl/unix/dltest/configure @@ -398,7 +398,7 @@ else fi -# SCCS: %Z% %M% %I% %E% %U% +# SCCS: @(#) configure.in 1.9 96/04/15 09:50:20 # Recover information that Tcl computed with its configure script. diff --git a/contrib/tcl/unix/ldAix b/contrib/tcl/unix/ldAix index d7f0275..4da2b20 100755 --- a/contrib/tcl/unix/ldAix +++ b/contrib/tcl/unix/ldAix @@ -10,7 +10,7 @@ # symbols exported by those files, and then invokes "ldCmd" to # perform the real link. # -# SCCS: @(#) ldAix 1.7 96/03/27 09:45:03 +# SCCS: @(#) ldAix 1.8 97/02/21 14:50:27 # Extract from the arguments the names of all of the object files. @@ -43,7 +43,7 @@ done # 8. Eliminate everything after the first field in a line, so that we're # left with just the symbol name. -nmopts="-g" +nmopts="-g -C" osver=`uname -v` if test $osver -eq 3; then nmopts="-e" diff --git a/contrib/tcl/unix/mkLinks b/contrib/tcl/unix/mkLinks index 93b577d..21d9f1c 100755 --- a/contrib/tcl/unix/mkLinks +++ b/contrib/tcl/unix/mkLinks @@ -27,10 +27,26 @@ rm xyzzyTe* if test "$x" != "xyzzyTestingAVeryLongFileName.foo"; then exit 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 @@ -43,6 +59,10 @@ 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 @@ -51,6 +71,14 @@ 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 @@ -75,6 +103,10 @@ 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 @@ -99,10 +131,18 @@ 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 @@ -143,9 +183,9 @@ if test -r CrtMathFnc.3; then rm -f Tcl_CreateMathFunc.3 ln CrtMathFnc.3 Tcl_CreateMathFunc.3 fi -if test -r CrtModalTmt.3; then - rm -f Tcl_CreateModalTimeout.3 - ln CrtModalTmt.3 Tcl_CreateModalTimeout.3 +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 @@ -203,6 +243,10 @@ 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 @@ -215,14 +259,22 @@ if test -r CrtCloseHdlr.3; then rm -f Tcl_DeleteCloseHandler.3 ln CrtCloseHdlr.3 Tcl_DeleteCloseHandler.3 fi -if test -r CrtCommand.3; then +if test -r CrtObjCmd.3; then rm -f Tcl_DeleteCommand.3 - ln CrtCommand.3 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 @@ -243,10 +295,6 @@ if test -r CrtInterp.3; then rm -f Tcl_DeleteInterp.3 ln CrtInterp.3 Tcl_DeleteInterp.3 fi -if test -r CrtModalTmt.3; then - rm -f Tcl_DeleteModalTimeout.3 - ln CrtModalTmt.3 Tcl_DeleteModalTimeout.3 -fi if test -r CrtTimerHdlr.3; then rm -f Tcl_DeleteTimerHandler.3 ln CrtTimerHdlr.3 Tcl_DeleteTimerHandler.3 @@ -271,6 +319,10 @@ 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 @@ -283,6 +335,10 @@ 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 @@ -291,25 +347,45 @@ 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 Notifier.3; then - rm -f Tcl_FileReady.3 - ln Notifier.3 Tcl_FileReady.3 +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 @@ -331,17 +407,13 @@ if test -r Alloc.3; then rm -f Tcl_Free.3 ln Alloc.3 Tcl_Free.3 fi -if test -r GetFile.3; then - rm -f Tcl_FreeFile.3 - ln GetFile.3 Tcl_FreeFile.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_GetAliases.3 - ln CrtSlave.3 Tcl_GetAliases.3 + rm -f Tcl_GetAliasObj.3 + ln CrtSlave.3 Tcl_GetAliasObj.3 fi if test -r AssocData.3; then rm -f Tcl_GetAssocData.3 @@ -351,19 +423,31 @@ 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_GetChannelFile.3 - ln CrtChannel.3 Tcl_GetChannelFile.3 + 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 @@ -375,26 +459,26 @@ if test -r CrtChannel.3; then rm -f Tcl_GetChannelType.3 ln CrtChannel.3 Tcl_GetChannelType.3 fi -if test -r CrtCommand.3; then +if test -r CrtObjCmd.3; then rm -f Tcl_GetCommandInfo.3 - ln CrtCommand.3 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 GetFile.3; then - rm -f Tcl_GetFile.3 - ln GetFile.3 Tcl_GetFile.3 -fi -if test -r GetFile.3; then - rm -f Tcl_GetFileInfo.3 - ln GetFile.3 Tcl_GetFileInfo.3 -fi if test -r Hash.3; then rm -f Tcl_GetHashKey.3 ln Hash.3 Tcl_GetHashKey.3 @@ -403,14 +487,38 @@ 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 @@ -419,18 +527,26 @@ 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 CrtSlave.3; then - rm -f Tcl_GetSlaves.3 - ln CrtSlave.3 Tcl_GetSlaves.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 @@ -447,10 +563,22 @@ 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 @@ -459,6 +587,10 @@ 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 @@ -471,6 +603,10 @@ 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 @@ -479,18 +615,90 @@ 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 @@ -563,6 +771,14 @@ 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 @@ -579,10 +795,22 @@ 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 @@ -591,14 +819,18 @@ if test -r OpenFileChnl.3; then rm -f Tcl_SetChannelOption.3 ln OpenFileChnl.3 Tcl_SetChannelOption.3 fi -if test -r CrtCommand.3; then +if test -r CrtObjCmd.3; then rm -f Tcl_SetCommandInfo.3 - ln CrtCommand.3 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 @@ -611,10 +843,30 @@ 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 @@ -623,10 +875,22 @@ 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 @@ -675,6 +939,10 @@ 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 @@ -719,14 +987,14 @@ if test -r Notifier.3; then rm -f Tcl_WaitForEvent.3 ln Notifier.3 Tcl_WaitForEvent.3 fi -if test -r Notifier.3; then - rm -f Tcl_WatchFile.3 - ln Notifier.3 Tcl_WatchFile.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 diff --git a/contrib/tcl/unix/porting.notes b/contrib/tcl/unix/porting.notes index e018b9d..39b35cb 100644 --- a/contrib/tcl/unix/porting.notes +++ b/contrib/tcl/unix/porting.notes @@ -26,7 +26,7 @@ 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.17 96/05/18 16:49:24 +sccsid = SCCS: @(#) porting.notes 1.18 96/12/31 14:50:27 -------------------------------------------- Solaris, various versions @@ -345,7 +345,7 @@ 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@sco.com> +Mark Diekhans <markd@grizzly.com> -------------------------------------------- SCO Unix 3.2.5 (ODT 5.0) @@ -354,7 +354,7 @@ 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@sco.com> +Mark Diekhans <markd@grizzly.com> -------------------------------------------- Linux 1.2.13 (gcc 2.7.0, libc.so.5.0.9) diff --git a/contrib/tcl/unix/tclAppInit.c b/contrib/tcl/unix/tclAppInit.c index a9479b3..fafa31e 100644 --- a/contrib/tcl/unix/tclAppInit.c +++ b/contrib/tcl/unix/tclAppInit.c @@ -5,14 +5,18 @@ * procedure for Tcl applications (without Tk). * * Copyright (c) 1993 The Regents of the University of California. - * Copyright (c) 1994-1995 Sun Microsystems, Inc. + * 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.17 96/03/26 12:45:29 + * SCCS: @(#) tclAppInit.c 1.20 97/03/24 14:29:43 */ +#ifdef TCL_XT_TEST +#include <X11/Intrinsic.h> +#endif + #include "tcl.h" /* @@ -23,9 +27,14 @@ 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 /* *---------------------------------------------------------------------- @@ -49,6 +58,9 @@ 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. */ } @@ -81,11 +93,19 @@ Tcl_AppInit(interp) } #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 */ /* diff --git a/contrib/tcl/unix/tclConfig.sh.in b/contrib/tcl/unix/tclConfig.sh.in index e6d4b04..f75782e 100644 --- a/contrib/tcl/unix/tclConfig.sh.in +++ b/contrib/tcl/unix/tclConfig.sh.in @@ -9,12 +9,13 @@ # # The information in this file is specific to a single platform. # -# SCCS: @(#) tclConfig.sh.in 1.15 96/04/17 10:46:27 +# SCCS: @(#) tclConfig.sh.in 1.19 96/12/17 09:08:29 # 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@' @@ -61,7 +62,7 @@ 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_INSTALL_DIR" defined in the Makefile. +# 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 @@ -97,3 +98,16 @@ TCL_SHARED_LIB_SUFFIX='@TCL_SHARED_LIB_SUFFIX@' # 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/contrib/tcl/unix/tclLoadAix.c b/contrib/tcl/unix/tclLoadAix.c index a940ca3..edf33d6b 100644 --- a/contrib/tcl/unix/tclLoadAix.c +++ b/contrib/tcl/unix/tclLoadAix.c @@ -17,7 +17,7 @@ * for any results of using the software, alterations are clearly marked * as such, and this notice is not modified. * - * SCCS: @(#) tclLoadAix.c 1.10 96/03/26 13:18:21 + * 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. @@ -92,7 +92,7 @@ static int readExports(ModulePtr); static void terminate(void); static void *findMain(void); -void *dlopen(const char *path, int mode) +VOID *dlopen(const char *path, int mode) { register ModulePtr mp; static void *mainModule; @@ -113,13 +113,13 @@ void *dlopen(const char *path, int mode) for (mp = modList; mp; mp = mp->next) if (strcmp(mp->name, path) == 0) { mp->refCnt++; - return mp; + return (VOID *) mp; } if ((mp = (ModulePtr)calloc(1, sizeof(*mp))) == NULL) { errvalid++; strcpy(errbuf, "calloc: "); strcat(errbuf, strerror(errno)); - return NULL; + return (VOID *) NULL; } mp->name = malloc((unsigned) (strlen(path) + 1)); strcpy(mp->name, path); @@ -150,7 +150,7 @@ void *dlopen(const char *path, int mode) } } else strcat(errbuf, strerror(errno)); - return NULL; + return (VOID *) NULL; } mp->refCnt = 1; mp->next = modList; @@ -160,7 +160,7 @@ void *dlopen(const char *path, int mode) errvalid++; strcpy(errbuf, "loadbind: "); strcat(errbuf, strerror(errno)); - return NULL; + return (VOID *) NULL; } /* * If the user wants global binding, loadbind against all other @@ -174,12 +174,12 @@ void *dlopen(const char *path, int mode) errvalid++; strcpy(errbuf, "loadbind: "); strcat(errbuf, strerror(errno)); - return NULL; + return (VOID *) NULL; } } if (readExports(mp) == -1) { dlclose(mp); - return NULL; + return (VOID *) NULL; } /* * If there is a dl_info structure, call the init function. @@ -200,7 +200,7 @@ void *dlopen(const char *path, int mode) } } else errvalid = 0; - return mp; + return (VOID *) mp; } /* @@ -242,7 +242,7 @@ static void caterr(char *s) } } -void *dlsym(void *handle, const char *symbol) +VOID *dlsym(void *handle, const char *symbol) { register ModulePtr mp = (ModulePtr)handle; register ExportPtr ep; diff --git a/contrib/tcl/unix/tclLoadAout.c b/contrib/tcl/unix/tclLoadAout.c index 29859a0..ade7161 100644 --- a/contrib/tcl/unix/tclLoadAout.c +++ b/contrib/tcl/unix/tclLoadAout.c @@ -14,7 +14,7 @@ * and Design Engineering (MADE) Initiative through ARPA contract * F33615-94-C-4400. * - * SCCS: @(#) tclLoadAout.c 1.7 96/02/15 11:58:53 + * SCCS: @(#) tclLoadAout.c 1.9 97/02/22 14:05:01 */ #include "tclInt.h" @@ -183,6 +183,8 @@ TclLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr) #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); @@ -429,5 +431,40 @@ TclGuessPackageName(fileName, bufPtr) Tcl_DString *bufPtr; /* Initialized empty dstring. Append * package name to this if possible. */ { - return 0; + 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/contrib/tcl/unix/tclLoadDl.c b/contrib/tcl/unix/tclLoadDl.c index 4f07363..2619bfd 100644 --- a/contrib/tcl/unix/tclLoadDl.c +++ b/contrib/tcl/unix/tclLoadDl.c @@ -10,7 +10,7 @@ * 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.7 96/03/14 09:03:33 + * SCCS: @(#) tclLoadDl.c 1.8 96/12/03 16:57:00 */ #include "tclInt.h" @@ -68,6 +68,7 @@ TclLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr) * to sym1 and sym2. */ { VOID *handle; + Tcl_DString newName; handle = dlopen(fileName, RTLD_NOW | RTLD_GLOBAL); if (handle == NULL) { @@ -75,8 +76,31 @@ TclLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr) "\": ", dlerror(), (char *) NULL); return TCL_ERROR; } - *proc1Ptr = (Tcl_PackageInitProc *) dlsym(handle, sym1); - *proc2Ptr = (Tcl_PackageInitProc *) dlsym(handle, sym2); + + /* + * 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; } diff --git a/contrib/tcl/unix/tclLoadDld.c b/contrib/tcl/unix/tclLoadDld.c index f2f949e..0ef994a 100644 --- a/contrib/tcl/unix/tclLoadDld.c +++ b/contrib/tcl/unix/tclLoadDld.c @@ -12,7 +12,7 @@ * 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.4 96/02/15 11:58:46 + * SCCS: @(#) tclLoadDld.c 1.5 97/05/14 13:24:22 */ #include "tclInt.h" @@ -69,7 +69,9 @@ TclLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr) if (firstTime) { if (tclExecutableName == NULL) { - interp->result = "don't know name of application binary file, so can't initialize dynamic loader"; + 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); diff --git a/contrib/tcl/unix/tclMtherr.c b/contrib/tcl/unix/tclMtherr.c index 2f56e00..24b815d 100644 --- a/contrib/tcl/unix/tclMtherr.c +++ b/contrib/tcl/unix/tclMtherr.c @@ -10,7 +10,7 @@ * 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.11 96/02/15 11:58:36 + * SCCS: @(#) tclMtherr.c 1.12 96/06/22 16:36:57 */ #include "tclInt.h" @@ -23,7 +23,7 @@ #endif #ifdef NO_ERRNO_H -extern int errno; /* Use errno from tclExpr.c. */ +extern int errno; /* Use errno from tclExecute.c. */ #define EDOM 33 #define ERANGE 34 #endif diff --git a/contrib/tcl/unix/tclUnixChan.c b/contrib/tcl/unix/tclUnixChan.c index a48806f..2e53440 100644 --- a/contrib/tcl/unix/tclUnixChan.c +++ b/contrib/tcl/unix/tclUnixChan.c @@ -4,43 +4,98 @@ * Common channel driver for Unix channels based on files, command * pipes and TCP sockets. * - * Copyright (c) 1995-1996 Sun Microsystems, Inc. + * 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.172 96/06/11 10:14:51 + * SCCS: @(#) tclUnixChan.c 1.203 97/06/20 13:03:18 */ #include "tclInt.h" /* Internal definitions for Tcl. */ #include "tclPort.h" /* Portability features for Tcl. */ /* - * This structure describes per-instance state of a pipe based channel. + * 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 */ -typedef struct PipeState { - Tcl_File readFile; /* Output from pipe. */ - Tcl_File writeFile; /* Input to pipe. */ - Tcl_File errorFile; /* Error output from pipe. */ - int numPids; /* How many processes are attached to this pipe? */ - int *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; +/* + * 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 { - int flags; /* ORed combination of the - * bitfields defined below. */ - Tcl_File sock; /* The socket itself. */ - Tcl_TcpAcceptProc *acceptProc; /* Proc to call on accept. */ - ClientData acceptProcData; /* The data for the accept proc. */ + 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; /* @@ -58,7 +113,14 @@ typedef struct TcpState { * the connection request will fail. */ -#define TCL_LISTEN_LIMIT 100 +#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 @@ -78,42 +140,52 @@ static int CreateSocketAddress _ANSI_ARGS_( (struct sockaddr_in *sockaddrPtr, char *host, int port)); static int FileBlockModeProc _ANSI_ARGS_(( - ClientData instanceData, Tcl_File inFile, - Tcl_File outFile, int mode)); + ClientData instanceData, int mode)); static int FileCloseProc _ANSI_ARGS_((ClientData instanceData, - Tcl_Interp *interp, Tcl_File inFile, - Tcl_File outFile)); -static int FilePipeInputProc _ANSI_ARGS_((ClientData instanceData, - Tcl_File inFile, char *buf, int toRead, - int *errorCode)); -static int FilePipeOutputProc _ANSI_ARGS_(( - ClientData instanceData, Tcl_File outFile, - char *buf, int toWrite, int *errorCode)); + 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, - Tcl_File inFile, Tcl_File outFile, long offset, - int mode, int *errorCode)); -static int PipeBlockModeProc _ANSI_ARGS_(( - ClientData instanceData, Tcl_File inFile, - Tcl_File outFile, int mode)); -static int PipeCloseProc _ANSI_ARGS_((ClientData instanceData, - Tcl_Interp *interp, Tcl_File inFile, - Tcl_File outFile)); + 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, - Tcl_File inFile, Tcl_File outFile, int mode)); + int mode)); static int TcpCloseProc _ANSI_ARGS_((ClientData instanceData, - Tcl_Interp *interp, Tcl_File inFile, - Tcl_File outFile)); + Tcl_Interp *interp)); +static int TcpGetHandleProc _ANSI_ARGS_((ClientData instanceData, + int direction, ClientData *handlePtr)); static int TcpGetOptionProc _ANSI_ARGS_((ClientData instanceData, - char *optionName, Tcl_DString *dsPtr)); + Tcl_Interp *interp, char *optionName, + Tcl_DString *dsPtr)); static int TcpInputProc _ANSI_ARGS_((ClientData instanceData, - Tcl_File infile, char *buf, int toRead, - int *errorCode)); + char *buf, int toRead, int *errorCode)); static int TcpOutputProc _ANSI_ARGS_((ClientData instanceData, - Tcl_File outFile, char *buf, int toWrite, - int *errorCode)); + 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, - Tcl_File fileToWaitFor, int *errorCodePtr)); + int *errorCodePtr)); /* * This structure describes the channel type structure for file based IO: @@ -123,27 +195,31 @@ static Tcl_ChannelType fileChannelType = { "file", /* Type name. */ FileBlockModeProc, /* Set blocking/nonblocking mode.*/ FileCloseProc, /* Close proc. */ - FilePipeInputProc, /* Input proc. */ - FilePipeOutputProc, /* Output 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 command pipe - * based IO: + * This structure describes the channel type structure for serial IO. + * Note that this type is a subclass of the "file" type. */ -static Tcl_ChannelType pipeChannelType = { - "pipe", /* Type name. */ - PipeBlockModeProc, /* Set blocking/nonblocking mode.*/ - PipeCloseProc, /* Close proc. */ - FilePipeInputProc, /* Input proc. */ - FilePipeOutputProc, /* Output proc. */ +static Tcl_ChannelType ttyChannelType = { + "tty", /* Type name. */ + FileBlockModeProc, /* Set blocking/nonblocking mode.*/ + FileCloseProc, /* Close proc. */ + FileInputProc, /* Input proc. */ + FileOutputProc, /* Output proc. */ NULL, /* Seek proc. */ - NULL, /* Set option proc. */ - NULL, /* Get option proc. */ + TtySetOptionProc, /* Set option proc. */ + TtyGetOptionProc, /* Get option proc. */ + FileWatchProc, /* Initialize notifier. */ + FileGetHandleProc, /* Get OS handles out of channel. */ }; /* @@ -160,7 +236,10 @@ static Tcl_ChannelType tcpChannelType = { NULL, /* Seek proc. */ NULL, /* Set option proc. */ TcpGetOptionProc, /* Get option proc. */ + TcpWatchProc, /* Initialize notifier. */ + TcpGetHandleProc, /* Get OS handles out of channel. */ }; + /* *---------------------------------------------------------------------- @@ -168,8 +247,7 @@ static Tcl_ChannelType tcpChannelType = { * FileBlockModeProc -- * * Helper procedure to set blocking and nonblocking modes on a - * channel. Invoked either by generic IO level code or by other - * channel drivers after doing channel-type-specific inialization. + * file based channel. Invoked by generic IO level code. * * Results: * 0 if successful, errno when failed. @@ -182,115 +260,46 @@ static Tcl_ChannelType tcpChannelType = { /* ARGSUSED */ static int -FileBlockModeProc(instanceData, inFile, outFile, mode) - ClientData instanceData; /* Unused. */ - Tcl_File inFile, outFile; /* Input, output files for channel. */ +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; - int fd; - if (inFile != NULL) { - fd = (int) Tcl_GetFileInfo(inFile, NULL); - 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); +#ifndef USE_FIONBIO + curStatus = fcntl(fsPtr->fd, F_GETFL); + if (mode == TCL_MODE_BLOCKING) { + curStatus &= (~(O_NONBLOCK)); + } else { + curStatus |= O_NONBLOCK; } - if (outFile != NULL) { - fd = (int) Tcl_GetFileInfo(outFile, NULL); - curStatus = fcntl(fd, F_GETFL); - if (mode == TCL_MODE_BLOCKING) { - curStatus &= (~(O_NONBLOCK)); - } else { - curStatus |= O_NONBLOCK; - } - if (fcntl(fd, F_SETFL, curStatus) < 0) { - return errno; - } + if (fcntl(fsPtr->fd, F_SETFL, curStatus) < 0) { + return errno; } - - return 0; -} - -/* - *---------------------------------------------------------------------- - * - * PipeBlockModeProc -- - * - * Helper procedure to set blocking and nonblocking modes on a - * channel. Invoked either by generic IO level code or by other - * channel drivers after doing channel-type-specific inialization. - * - * Results: - * 0 if successful, errno when failed. - * - * Side effects: - * Sets the device into blocking or non-blocking mode. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -static int -PipeBlockModeProc(instanceData, inFile, outFile, mode) - ClientData instanceData; /* The pipe state. */ - Tcl_File inFile, outFile; /* Input, output files for channel. */ - int mode; /* The mode to set. Can be one of - * TCL_MODE_BLOCKING or - * TCL_MODE_NONBLOCKING. */ -{ - PipeState *pipePtr; - int curStatus; - int fd; - - if (inFile != NULL) { - fd = (int) Tcl_GetFileInfo(inFile, NULL); - 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); + curStatus = fcntl(fsPtr->fd, F_GETFL); +#else + if (mode == TCL_MODE_BLOCKING) { + curStatus = 0; + } else { + curStatus = 1; } - if (outFile != NULL) { - fd = (int) Tcl_GetFileInfo(outFile, NULL); - curStatus = fcntl(fd, F_GETFL); - if (mode == TCL_MODE_BLOCKING) { - curStatus &= (~(O_NONBLOCK)); - } else { - curStatus |= O_NONBLOCK; - } - if (fcntl(fd, F_SETFL, curStatus) < 0) { - return errno; - } + if (ioctl(fsPtr->fd, (int) FIONBIO, &curStatus) < 0) { + return errno; } - - pipePtr = (PipeState *) instanceData; - pipePtr->isNonBlocking = (mode == TCL_MODE_NONBLOCKING) ? 1 : 0; - +#endif return 0; } /* *---------------------------------------------------------------------- * - * FilePipeInputProc -- + * FileInputProc -- * * This procedure is invoked from the generic IO level to read - * input from a file or command pipeline channel. + * input from a file based channel. * * Results: * The number of bytes read is returned or -1 on error. An output @@ -302,22 +311,19 @@ PipeBlockModeProc(instanceData, inFile, outFile, mode) *---------------------------------------------------------------------- */ - /* ARGSUSED */ static int -FilePipeInputProc(instanceData, inFile, buf, toRead, errorCodePtr) - ClientData instanceData; /* Unused. */ - Tcl_File inFile; /* Input device for channel. */ +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. */ { - int fd; /* The OS handle for reading. */ + FileState *fsPtr = (FileState *) instanceData; int bytesRead; /* How many bytes were actually * read from the input device? */ *errorCodePtr = 0; - fd = (int) Tcl_GetFileInfo(inFile, NULL); /* * Assume there is always enough input available. This will block @@ -326,7 +332,7 @@ FilePipeInputProc(instanceData, inFile, buf, toRead, errorCodePtr) * nonblocking, the read will never block. */ - bytesRead = read(fd, buf, (size_t) toRead); + bytesRead = read(fsPtr->fd, buf, (size_t) toRead); if (bytesRead > -1) { return bytesRead; } @@ -337,10 +343,10 @@ FilePipeInputProc(instanceData, inFile, buf, toRead, errorCodePtr) /* *---------------------------------------------------------------------- * - * FilePipeOutputProc-- + * FileOutputProc-- * * This procedure is invoked from the generic IO level to write - * output to a file or command pipeline channel. + * output to a file channel. * * Results: * The number of bytes written is returned or -1 on error. An @@ -353,21 +359,18 @@ FilePipeInputProc(instanceData, inFile, buf, toRead, errorCodePtr) *---------------------------------------------------------------------- */ - /* ARGSUSED */ static int -FilePipeOutputProc(instanceData, outFile, buf, toWrite, errorCodePtr) - ClientData instanceData; /* Unused. */ - Tcl_File outFile; /* Output device for channel. */ +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; - int fd; *errorCodePtr = 0; - fd = (int) Tcl_GetFileInfo(outFile, NULL); - written = write(fd, buf, (size_t) toWrite); + written = write(fsPtr->fd, buf, (size_t) toWrite); if (written > -1) { return written; } @@ -392,52 +395,30 @@ FilePipeOutputProc(instanceData, outFile, buf, toWrite, errorCodePtr) *---------------------------------------------------------------------- */ - /* ARGSUSED */ static int -FileCloseProc(instanceData, interp, inFile, outFile) - ClientData instanceData; /* Unused. */ +FileCloseProc(instanceData, interp) + ClientData instanceData; /* File state. */ Tcl_Interp *interp; /* For error reporting - unused. */ - Tcl_File inFile; /* Input file to close. */ - Tcl_File outFile; /* Output file to close. */ { - int fd, errorCode = 0; - - if (inFile != NULL) { - - /* - * Check for read/write file so we only close it once. - */ + FileState *fsPtr = (FileState *) instanceData; + FileState **nextPtrPtr; + int errorCode = 0; - if (inFile == outFile) { - outFile = NULL; + Tcl_DeleteFileHandler(fsPtr->fd); + if (!TclInExit() + || ((fsPtr->fd != 0) && (fsPtr->fd != 1) && (fsPtr->fd != 2))) { + if (close(fsPtr->fd) < 0) { + errorCode = errno; } - fd = (int) Tcl_GetFileInfo(inFile, NULL); - Tcl_FreeFile(inFile); - - if (tclInInterpreterDeletion) { - if ((fd != 0) && (fd != 1) && (fd != 2)) { - if (close(fd) < 0) { - errorCode = errno; - } - } - } else if (close(fd) < 0) { - errorCode = errno; - } } - - if (outFile != NULL) { - fd = (int) Tcl_GetFileInfo(outFile, NULL); - Tcl_FreeFile(outFile); - if (tclInInterpreterDeletion) { - if ((fd != 0) && (fd != 1) && (fd != 2)) { - if ((close(fd) < 0) && (errorCode == 0)) { - errorCode = errno; - } - } - } else if ((close(fd) < 0) && (errorCode == 0)) { - errorCode = errno; - } + for (nextPtrPtr = &firstFilePtr; (*nextPtrPtr) != NULL; + nextPtrPtr = &((*nextPtrPtr)->nextPtr)) { + if ((*nextPtrPtr) == fsPtr) { + (*nextPtrPtr) = fsPtr->nextPtr; + break; + } } + ckfree((char *) fsPtr); return errorCode; } @@ -461,12 +442,9 @@ FileCloseProc(instanceData, interp, inFile, outFile) *---------------------------------------------------------------------- */ - /* ARGSUSED */ static int -FileSeekProc(instanceData, inFile, outFile, offset, mode, errorCodePtr) - ClientData instanceData; /* Unused. */ - Tcl_File inFile, outFile; /* Input and output - * files for channel. */ +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 @@ -474,158 +452,699 @@ FileSeekProc(instanceData, inFile, outFile, offset, mode, errorCodePtr) * SEEK_SET or SEEK_END. */ int *errorCodePtr; /* To store error code. */ { + FileState *fsPtr = (FileState *) instanceData; int newLoc; - int fd; - *errorCodePtr = 0; - if (inFile != (Tcl_File) NULL) { - fd = (int) Tcl_GetFileInfo(inFile, NULL); - } else if (outFile != (Tcl_File) NULL) { - fd = (int) Tcl_GetFileInfo(outFile, NULL); - } else { - *errorCodePtr = EFAULT; - return -1; - } - newLoc = lseek(fd, offset, mode); - if (newLoc > -1) { - return newLoc; - } - *errorCodePtr = errno; - return -1; + newLoc = lseek(fsPtr->fd, offset, mode); + + *errorCodePtr = (newLoc == -1) ? errno : 0; + return newLoc; } /* *---------------------------------------------------------------------- * - * TclGetAndDetachPids -- + * FileWatchProc -- * - * 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. + * Initialize the notifier to watch the fd from this channel. * * Results: * None. * * Side effects: - * Modifies interp->result. Detaches processes. + * Sets up the notifier so that a future event on the channel will + * be seen by Tcl. * *---------------------------------------------------------------------- */ -void -TclGetAndDetachPids(interp, chan) - Tcl_Interp *interp; - Tcl_Channel chan; +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. */ { - PipeState *pipePtr; - Tcl_ChannelType *chanTypePtr; - int i; - char buf[20]; + FileState *fsPtr = (FileState *) instanceData; /* - * Punt if the channel is not a command channel. + * 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. */ - chanTypePtr = Tcl_GetChannelType(chan); - if (chanTypePtr != &pipeChannelType) { - return; + 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; - pipePtr = (PipeState *) Tcl_GetChannelInstanceData(chan); - for (i = 0; i < pipePtr->numPids; i++) { - sprintf(buf, "%d", pipePtr->pidPtr[i]); - Tcl_AppendElement(interp, buf); - Tcl_DetachPids(1, &(pipePtr->pidPtr[i])); + if (direction & fsPtr->validMask) { + *handlePtr = (ClientData) fsPtr->fd; + return TCL_OK; + } else { + return TCL_ERROR; } - if (pipePtr->numPids > 0) { - ckfree((char *) pipePtr->pidPtr); - pipePtr->numPids = 0; +} + +/* + *---------------------------------------------------------------------- + * + * 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"); } } /* *---------------------------------------------------------------------- * - * PipeCloseProc -- + * TtyGetOptionProc -- * - * This procedure is invoked by the generic IO level to perform - * channel-type-specific cleanup when a command pipeline channel - * is closed. + * 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: - * 0 on success, errno otherwise. + * A standard Tcl result. Also sets the supplied DString to the + * string value of the option(s) returned. * * Side effects: - * Closes the command pipeline channel. + * 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). * *---------------------------------------------------------------------- */ - /* ARGSUSED */ -static int -PipeCloseProc(instanceData, interp, inFile, outFile) - ClientData instanceData; /* The pipe to close. */ - Tcl_Interp *interp; /* For error reporting. */ - Tcl_File inFile, outFile; /* Unused. */ +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). */ { - PipeState *pipePtr; - Tcl_Channel errChan; - int fd, errorCode, result; - - errorCode = 0; - result = 0; - pipePtr = (PipeState *) instanceData; - if (pipePtr->readFile != NULL) { - fd = (int) Tcl_GetFileInfo(pipePtr->readFile, NULL); - Tcl_FreeFile(pipePtr->readFile); - if (close(fd) < 0) { - errorCode = errno; + 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; } } - if (pipePtr->writeFile != NULL) { - fd = (int) Tcl_GetFileInfo(pipePtr->writeFile, NULL); - Tcl_FreeFile(pipePtr->writeFile); - if ((close(fd) < 0) && (errorCode == 0)) { - errorCode = errno; + 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; - if (pipePtr->isNonBlocking) { + tcgetattr(fd, &termios); + ttyPtr->baud = TtyGetBaud(cfgetospeed(&termios)); - /* - * If the channel is non-blocking, just detach the children PIDs - * and discard the errorFile. - */ - - Tcl_DetachPids(pipePtr->numPids, pipePtr->pidPtr); - if (pipePtr->errorFile != NULL) { - Tcl_FreeFile(pipePtr->errorFile); - } - } else { - - /* - * Wrap the error file into a channel and give it to the cleanup - * routine. - */ + 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; + } - if (pipePtr->errorFile != NULL) { - errChan = Tcl_CreateChannel(&fileChannelType, "pipeError", - pipePtr->errorFile, NULL, NULL); - } else { - errChan = NULL; - } - result = TclCleanupChildren(interp, pipePtr->numPids, pipePtr->pidPtr, - errChan); + 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; + } } - if (pipePtr->numPids != 0) { - ckfree((char *) pipePtr->pidPtr); + 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; } - ckfree((char *) pipePtr); - if (errorCode == 0) { - return result; + 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; } - return errorCode; + *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; } /* @@ -659,10 +1178,10 @@ Tcl_OpenFileChannel(interp, fileName, modeString, permissions) * it? */ { int fd, seekFlag, mode, channelPermissions; - Tcl_File file; - Tcl_Channel chan; + FileState *fsPtr; char *nativeName, channelName[20]; Tcl_DString buffer; + Tcl_ChannelType *channelTypePtr; mode = TclGetOpenMode(interp, modeString, &seekFlag); if (mode == -1) { @@ -706,43 +1225,68 @@ Tcl_OpenFileChannel(interp, fileName, modeString, permissions) } return NULL; } - - sprintf(channelName, "file%d", fd); - file = Tcl_GetFile((ClientData) fd, TCL_UNIX_FD); - - chan = Tcl_CreateChannel(&fileChannelType, channelName, - (channelPermissions & TCL_READABLE) ? file : NULL, - (channelPermissions & TCL_WRITABLE) ? file : NULL, - (ClientData) NULL); /* - * The channel may not be open now, for example if we tried to - * open a file with permissions that cannot be satisfied. + * Set close-on-exec flag on the fd so that child processes will not + * inherit this fd. */ + + fcntl(fd, F_SETFD, FD_CLOEXEC); - if (chan == (Tcl_Channel) NULL) { - if (interp != (Tcl_Interp *) NULL) { - Tcl_AppendResult(interp, "couldn't create channel \"", - channelName, "\": ", Tcl_PosixError(interp), - (char *) NULL); - } - Tcl_FreeFile(file); - close(fd); - return NULL; + 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(chan, 0, SEEK_END) < 0) { + 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), - (char *) NULL); + channelName, "\": ", Tcl_PosixError(interp), NULL); } - Tcl_Close(NULL, chan); + Tcl_Close(NULL, fsPtr->channel); return NULL; } } - return chan; + + 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; } /* @@ -762,192 +1306,41 @@ Tcl_OpenFileChannel(interp, fileName, modeString, permissions) */ Tcl_Channel -Tcl_MakeFileChannel(inFd, outFd, mode) - ClientData inFd; /* OS level handle used for input. */ - ClientData outFd; /* OS level handle used for output. */ +Tcl_MakeFileChannel(handle, mode) + ClientData handle; /* OS level handle. */ int mode; /* ORed combination of TCL_READABLE and - * TCL_WRITABLE to indicate whether inFile - * and/or outFile are valid. */ + * TCL_WRITABLE to indicate file mode. */ { - Tcl_Channel chan; - int fileUsed; - Tcl_File inFile, outFile; + FileState *fsPtr; char channelName[20]; + int fd = (int) handle; if (mode == 0) { - return (Tcl_Channel) NULL; - } - - inFile = (Tcl_File) NULL; - outFile = (Tcl_File) NULL; - - if (mode & TCL_READABLE) { - sprintf(channelName, "file%d", (int) inFd); - inFile = Tcl_GetFile(inFd, TCL_UNIX_FD); - } - - if (mode & TCL_WRITABLE) { - sprintf(channelName, "file%d", (int) outFd); - outFile = Tcl_GetFile(outFd, TCL_UNIX_FD); + return NULL; } - /* - * Look to see if a channel with those two Tcl_Files already exists. - * If so, return it. - */ - - chan = TclFindFileChannel(inFile, outFile, &fileUsed); - if (chan != (Tcl_Channel) NULL) { - return chan; - } + sprintf(channelName, "file%d", fd); /* - * If one of the Tcl_Files is used in another channel, do not - * create a new channel containing it; this avoids core dumps - * later, when the Tcl_File would be freed twice. + * 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. */ - if (fileUsed) { - return (Tcl_Channel) NULL; - } - return Tcl_CreateChannel(&fileChannelType, channelName, inFile, outFile, - (ClientData) NULL); -} - -/* - *---------------------------------------------------------------------- - * - * TclCreateCommandChannel -- - * - * 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 -TclCreateCommandChannel(readFile, writeFile, errorFile, numPids, pidPtr) - Tcl_File readFile; /* If non-null, gives the file for reading. */ - Tcl_File writeFile; /* If non-null, gives the file for writing. */ - Tcl_File errorFile; /* If non-null, gives the file where errors - * can be read. */ - int numPids; /* The number of pids in the pid array. */ - int *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). */ -{ - Tcl_Channel channel; - char channelName[20]; - int channelId; - PipeState *statePtr = (PipeState *) ckalloc((unsigned) sizeof(PipeState)); - - statePtr->readFile = readFile; - statePtr->writeFile = writeFile; - statePtr->errorFile = errorFile; - statePtr->numPids = numPids; - statePtr->pidPtr = pidPtr; - statePtr->isNonBlocking = 0; - - /* - * Use one of the fds associated with the channel as the - * channel id. - */ - - if (readFile) { - channelId = (int) Tcl_GetFileInfo(readFile, NULL); - } else if (writeFile) { - channelId = (int) Tcl_GetFileInfo(writeFile, NULL); - } else if (errorFile) { - channelId = (int) Tcl_GetFileInfo(errorFile, NULL); - } 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); - channel = Tcl_CreateChannel(&pipeChannelType, channelName, readFile, - writeFile, (ClientData) statePtr); - - if (channel == NULL) { - - /* - * pidPtr will be freed by the caller if the return value is NULL. - */ - - ckfree((char *)statePtr); - } - return channel; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_PidCmd -- - * - * 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_PidCmd(dummy, interp, argc, argv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ -{ - Tcl_Channel chan; /* The channel to get pids for. */ - Tcl_ChannelType *chanTypePtr; /* The type of that channel. */ - PipeState *pipePtr; /* The pipe state. */ - int i; /* Loops over PIDs attached to the - * pipe. */ - char string[50]; /* Temp buffer for string rep. of - * PIDs attached to the pipe. */ - - if (argc > 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " ?channelId?\"", (char *) NULL); - return TCL_ERROR; - } - if (argc == 1) { - sprintf(interp->result, "%ld", (long) getpid()); - } else { - chan = Tcl_GetChannel(interp, argv[1], NULL); - if (chan == (Tcl_Channel) NULL) { - return TCL_ERROR; - } - chanTypePtr = Tcl_GetChannelType(chan); - if (chanTypePtr != &pipeChannelType) { - return TCL_OK; - } - pipePtr = (PipeState *) Tcl_GetChannelInstanceData(chan); - for (i = 0; i < pipePtr->numPids; i++) { - sprintf(string, "%d", pipePtr->pidPtr[i]); - Tcl_AppendElement(interp, string); + for (fsPtr = firstFilePtr; fsPtr != NULL; fsPtr = fsPtr->nextPtr) { + if (fsPtr->fd == fd) { + return (mode == fsPtr->validMask) ? fsPtr->channel : NULL; } } - return TCL_OK; + + 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; } /* @@ -969,22 +1362,46 @@ Tcl_PidCmd(dummy, interp, argc, argv) /* ARGSUSED */ static int -TcpBlockModeProc(instanceData, inFile, outFile, mode) +TcpBlockModeProc(instanceData, mode) ClientData instanceData; /* Socket state. */ - Tcl_File inFile, outFile; /* Input, output files for channel. */ int mode; /* The mode to set. Can be one of * TCL_MODE_BLOCKING or * TCL_MODE_NONBLOCKING. */ { - TcpState *statePtr; + TcpState *statePtr = (TcpState *) instanceData; + int setting; - statePtr = (TcpState *) instanceData; +#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; } - return FileBlockModeProc(instanceData, inFile, outFile, mode); + 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; } /* @@ -1005,12 +1422,10 @@ TcpBlockModeProc(instanceData, inFile, outFile, mode) */ static int -WaitForConnect(statePtr, fileToWaitFor, errorCodePtr) +WaitForConnect(statePtr, errorCodePtr) TcpState *statePtr; /* State of the socket. */ - Tcl_File fileToWaitFor; /* File to wait on to become connected. */ int *errorCodePtr; /* Where to store errors? */ { - int sock; /* The socket itself. */ int timeOut; /* How long to wait. */ int state; /* Of calling TclWaitForFile. */ int flags; /* fcntl flags for the socket. */ @@ -1027,13 +1442,19 @@ WaitForConnect(statePtr, fileToWaitFor, errorCodePtr) timeOut = -1; } errno = 0; - state = TclWaitForFile(fileToWaitFor, TCL_WRITABLE | TCL_EXCEPTION, - timeOut); + state = TclUnixWaitForFile(statePtr->fd, + TCL_WRITABLE | TCL_EXCEPTION, timeOut); if (!(statePtr->flags & TCP_ASYNC_SOCKET)) { - sock = (int) Tcl_GetFileInfo(statePtr->sock, NULL); - flags = fcntl(sock, F_GETFL); +#ifndef USE_FIONBIO + flags = fcntl(statePtr->fd, F_GETFL); flags &= (~(O_NONBLOCK)); - (void) fcntl(sock, F_SETFL, flags); + (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; @@ -1072,28 +1493,22 @@ WaitForConnect(statePtr, fileToWaitFor, errorCodePtr) /* ARGSUSED */ static int -TcpInputProc(instanceData, inFile, buf, bufSize, errorCodePtr) +TcpInputProc(instanceData, buf, bufSize, errorCodePtr) ClientData instanceData; /* Socket state. */ - Tcl_File inFile; /* Input device for channel. */ 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; /* The state of the socket. */ - int sock; /* The OS handle. */ - int bytesRead; /* How many bytes were read? */ - int state; /* Of waiting for connection. */ + TcpState *statePtr = (TcpState *) instanceData; + int bytesRead, state; *errorCodePtr = 0; - sock = (int) Tcl_GetFileInfo(inFile, NULL); - statePtr = (TcpState *) instanceData; - - state = WaitForConnect(statePtr, inFile, errorCodePtr); + state = WaitForConnect(statePtr, errorCodePtr); if (state != 0) { return -1; } - bytesRead = recv(sock, buf, bufSize, 0); + bytesRead = recv(statePtr->fd, buf, bufSize, 0); if (bytesRead > -1) { return bytesRead; } @@ -1131,26 +1546,22 @@ TcpInputProc(instanceData, inFile, buf, bufSize, errorCodePtr) */ static int -TcpOutputProc(instanceData, outFile, buf, toWrite, errorCodePtr) +TcpOutputProc(instanceData, buf, toWrite, errorCodePtr) ClientData instanceData; /* Socket state. */ - Tcl_File outFile; /* Output device for channel. */ char *buf; /* The data buffer. */ int toWrite; /* How many bytes to write? */ int *errorCodePtr; /* Where to store error code. */ { - TcpState *statePtr; + TcpState *statePtr = (TcpState *) instanceData; int written; - int sock; /* OS level socket. */ int state; /* Of waiting for connection. */ *errorCodePtr = 0; - sock = (int) Tcl_GetFileInfo(outFile, NULL); - statePtr = (TcpState *) instanceData; - state = WaitForConnect(statePtr, outFile, errorCodePtr); + state = WaitForConnect(statePtr, errorCodePtr); if (state != 0) { return -1; } - written = send(sock, buf, toWrite, 0); + written = send(statePtr->fd, buf, toWrite, 0); if (written > -1) { return written; } @@ -1178,20 +1589,13 @@ TcpOutputProc(instanceData, outFile, buf, toWrite, errorCodePtr) /* ARGSUSED */ static int -TcpCloseProc(instanceData, interp, inFile, outFile) +TcpCloseProc(instanceData, interp) ClientData instanceData; /* The socket to close. */ Tcl_Interp *interp; /* For error reporting - unused. */ - Tcl_File inFile, outFile; /* Unused. */ { - TcpState *statePtr; - Tcl_File sockFile; - int sock; + TcpState *statePtr = (TcpState *) instanceData; int errorCode = 0; - statePtr = (TcpState *) instanceData; - sockFile = statePtr->sock; - sock = (int) Tcl_GetFileInfo(sockFile, NULL); - /* * Delete a file handler that may be active for this socket if this * is a server socket - the file handler was created automatically @@ -1201,20 +1605,12 @@ TcpCloseProc(instanceData, interp, inFile, outFile) * delete them here. */ - Tcl_DeleteFileHandler(sockFile); - - ckfree((char *) statePtr); - - /* - * We assume that inFile==outFile==sockFile and so - * we only clean up sockFile. - */ - - Tcl_FreeFile(sockFile); + Tcl_DeleteFileHandler(statePtr->fd); - if (close(sock) < 0) { + if (close(statePtr->fd) < 0) { errorCode = errno; } + ckfree((char *) statePtr); return errorCode; } @@ -1232,7 +1628,7 @@ TcpCloseProc(instanceData, interp, inFile, outFile) * 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. + * supplied DString. Sets Error message if needed. * * Side effects: * None. @@ -1241,26 +1637,24 @@ TcpCloseProc(instanceData, interp, inFile, outFile) */ static int -TcpGetOptionProc(instanceData, optionName, dsPtr) - ClientData instanceData; /* Socket state. */ - 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. */ +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 *statePtr = (TcpState *) instanceData; struct sockaddr_in sockname; struct sockaddr_in peername; struct hostent *hostEntPtr; - int sock; int size = sizeof(struct sockaddr_in); size_t len = 0; char buf[128]; - statePtr = (TcpState *) instanceData; - sock = (int) Tcl_GetFileInfo(statePtr->sock, NULL); if (optionName != (char *) NULL) { len = strlen(optionName); } @@ -1268,7 +1662,8 @@ TcpGetOptionProc(instanceData, optionName, dsPtr) if ((len == 0) || ((len > 1) && (optionName[1] == 'p') && (strncmp(optionName, "-peername", len) == 0))) { - if (getpeername(sock, (struct sockaddr *) &peername, &size) >= 0) { + if (getpeername(statePtr->fd, (struct sockaddr *) &peername, &size) + >= 0) { if (len == 0) { Tcl_DStringAppendElement(dsPtr, "-peername"); Tcl_DStringStartSublist(dsPtr); @@ -1288,13 +1683,30 @@ TcpGetOptionProc(instanceData, optionName, 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(sock, (struct sockaddr *) &sockname, &size) >= 0) { + if (getsockname(statePtr->fd, (struct sockaddr *) &sockname, &size) + >= 0) { if (len == 0) { Tcl_DStringAppendElement(dsPtr, "-sockname"); Tcl_DStringStartSublist(dsPtr); @@ -1314,12 +1726,18 @@ TcpGetOptionProc(instanceData, optionName, 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) { - Tcl_SetErrno(EINVAL); - return TCL_ERROR; + return Tcl_BadChannelOption(interp, optionName, "peername sockname"); } return TCL_OK; @@ -1328,6 +1746,72 @@ TcpGetOptionProc(instanceData, optionName, dsPtr) /* *---------------------------------------------------------------------- * + * 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 @@ -1378,6 +1862,13 @@ CreateSocket(interp, port, host, server, myaddr, myport, async) } /* + * 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 */ @@ -1398,13 +1889,13 @@ CreateSocket(interp, port, host, server, myaddr, myport, async) status = bind(sock, (struct sockaddr *) &sockaddr, sizeof(struct sockaddr)); if (status != -1) { - status = listen(sock, TCL_LISTEN_LIMIT); + status = listen(sock, SOMAXCONN); } } else { if (myaddr != NULL || myport != 0) { - status = 1; - (void) setsockopt(sock, SOL_SOCKET, SO_REUSEADDR, (char *) &status, - sizeof(status)); + 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) { @@ -1420,9 +1911,16 @@ CreateSocket(interp, port, host, server, myaddr, myport, async) */ 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; } @@ -1459,7 +1957,7 @@ bindError: if (asyncConnect) { statePtr->flags = TCP_ASYNC_CONNECT; } - statePtr->sock = Tcl_GetFile((ClientData) sock, TCL_UNIX_FD); + statePtr->fd = sock; return statePtr; @@ -1565,7 +2063,6 @@ Tcl_OpenTcpClient(interp, port, host, myaddr, myport, async) * asynchronous connect. Otherwise * we do a blocking connect. */ { - Tcl_Channel chan; TcpState *statePtr; char channelName[20]; @@ -1581,17 +2078,16 @@ Tcl_OpenTcpClient(interp, port, host, myaddr, myport, async) statePtr->acceptProc = NULL; statePtr->acceptProcData = (ClientData) NULL; - sprintf(channelName, "sock%d", - (int) Tcl_GetFileInfo(statePtr->sock, NULL)); + sprintf(channelName, "sock%d", statePtr->fd); - chan = Tcl_CreateChannel(&tcpChannelType, channelName, statePtr->sock, - statePtr->sock, (ClientData) statePtr); - if (Tcl_SetChannelOption(interp, chan, "-translation", "auto crlf") == - TCL_ERROR) { - Tcl_Close((Tcl_Interp *) NULL, chan); + 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 chan; + return statePtr->channel; } /* @@ -1615,26 +2111,23 @@ Tcl_MakeTcpClientChannel(sock) ClientData sock; /* The socket to wrap up into a channel. */ { TcpState *statePtr; - Tcl_File sockFile; char channelName[20]; - Tcl_Channel chan; - sockFile = Tcl_GetFile(sock, TCL_UNIX_FD); statePtr = (TcpState *) ckalloc((unsigned) sizeof(TcpState)); - statePtr->sock = sockFile; + statePtr->fd = (int) sock; statePtr->acceptProc = NULL; statePtr->acceptProcData = (ClientData) NULL; - sprintf(channelName, "sock%d", (int) sock); + sprintf(channelName, "sock%d", statePtr->fd); - chan = Tcl_CreateChannel(&tcpChannelType, channelName, sockFile, sockFile, - (ClientData) statePtr); - if (Tcl_SetChannelOption((Tcl_Interp *) NULL, chan, "-translation", - "auto crlf") == TCL_ERROR) { - Tcl_Close((Tcl_Interp *) NULL, chan); + 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 chan; + return statePtr->channel; } /* @@ -1665,7 +2158,6 @@ Tcl_OpenTcpServer(interp, port, myHost, acceptProc, acceptProcData) * from new clients. */ ClientData acceptProcData; /* Data for the callback. */ { - Tcl_Channel chan; TcpState *statePtr; char channelName[20]; @@ -1686,13 +2178,12 @@ Tcl_OpenTcpServer(interp, port, myHost, acceptProc, acceptProcData) * from new clients. */ - Tcl_CreateFileHandler(statePtr->sock, TCL_READABLE, TcpAccept, + Tcl_CreateFileHandler(statePtr->fd, TCL_READABLE, TcpAccept, (ClientData) statePtr); - sprintf(channelName, "sock%d", - (int) Tcl_GetFileInfo(statePtr->sock, NULL)); - chan = Tcl_CreateChannel(&tcpChannelType, channelName, NULL, NULL, - (ClientData) statePtr); - return chan; + sprintf(channelName, "sock%d", statePtr->fd); + statePtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName, + (ClientData) statePtr, 0); + return statePtr->channel; } /* @@ -1719,48 +2210,44 @@ TcpAccept(data, mask) { TcpState *sockState; /* Client data of server socket. */ int newsock; /* The new client socket */ - Tcl_File newFile; /* Its file. */ TcpState *newSockState; /* State for new socket. */ struct sockaddr_in addr; /* The remote address */ int len; /* For accept interface */ - Tcl_Channel chan; /* Channel instance created. */ char channelName[20]; sockState = (TcpState *) data; len = sizeof(struct sockaddr_in); - newsock = accept((int) Tcl_GetFileInfo(sockState->sock, NULL), - (struct sockaddr *)&addr, &len); + 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); - newFile = Tcl_GetFile((ClientData) newsock, TCL_UNIX_FD); - if (newFile) { - newSockState = (TcpState *) ckalloc((unsigned) sizeof(TcpState)); - - newSockState->flags = 0; - newSockState->sock = newFile; - newSockState->acceptProc = (Tcl_TcpAcceptProc *) NULL; - newSockState->acceptProcData = (ClientData) NULL; + 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", (int) newsock); - chan = Tcl_CreateChannel(&tcpChannelType, channelName, newFile, - newFile, (ClientData) newSockState); - if (chan == (Tcl_Channel) NULL) { - ckfree((char *) newSockState); - close(newsock); - Tcl_FreeFile(newFile); - } else { - if (Tcl_SetChannelOption((Tcl_Interp *) NULL, chan, "-translation", - "auto crlf") == TCL_ERROR) { - Tcl_Close((Tcl_Interp *) NULL, chan); - } - if (sockState->acceptProc != (Tcl_TcpAcceptProc *) NULL) { - (sockState->acceptProc) (sockState->acceptProcData, chan, - inet_ntoa(addr.sin_addr), ntohs(addr.sin_port)); - } - } + 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)); } } @@ -1824,56 +2311,20 @@ TclGetDefaultStdChannel(type) break; } - channel = Tcl_MakeFileChannel((ClientData) fd, (ClientData) fd, mode); + channel = Tcl_MakeFileChannel((ClientData) fd, mode); /* * Set up the normal channel options for stdio handles. */ - if (Tcl_SetChannelOption(NULL, channel, "-translation", "auto") == - TCL_ERROR) { - Tcl_Close((Tcl_Interp *) NULL, channel); - return NULL; - } - if (Tcl_SetChannelOption(NULL, channel, "-buffering", bufMode) == - TCL_ERROR) { - Tcl_Close((Tcl_Interp *) NULL, channel); - return NULL; - } + Tcl_SetChannelOption(NULL, channel, "-translation", "auto"); + Tcl_SetChannelOption(NULL, channel, "-buffering", bufMode); return channel; } /* *---------------------------------------------------------------------- * - * TclClosePipeFile -- - * - * This function is a simple wrapper for close on a file or - * pipe handle. Called in the generic command pipeline cleanup - * code to do platform specific closing of the files associated - * with the command channel. - * - * Results: - * None. - * - * Side effects: - * Closes the fd and frees the Tcl_File. - * - *---------------------------------------------------------------------- - */ - -void -TclClosePipeFile(file) - Tcl_File file; -{ - int fd = (int) Tcl_GetFileInfo(file, NULL); - close(fd); - Tcl_FreeFile(file); -} - -/* - *---------------------------------------------------------------------- - * * Tcl_GetOpenFile -- * * Given a name of a channel registered in the given interpreter, @@ -1909,7 +2360,6 @@ Tcl_GetOpenFile(interp, string, forWriting, checkUsage, filePtr) Tcl_Channel chan; int chanMode; Tcl_ChannelType *chanTypePtr; - Tcl_File tf; int fd; FILE *f; @@ -1934,30 +2384,180 @@ Tcl_GetOpenFile(interp, string, forWriting, checkUsage, filePtr) */ chanTypePtr = Tcl_GetChannelType(chan); - if ((chanTypePtr == &fileChannelType) || (chanTypePtr == &pipeChannelType) - || (chanTypePtr == &tcpChannelType)) { - tf = Tcl_GetChannelFile(chan, - (forWriting ? TCL_WRITABLE : TCL_READABLE)); - fd = (int) Tcl_GetFileInfo(tf, NULL); - - /* - * The call to fdopen below is probably dangerous, since it will - * truncate an existing file if the file is being opened - * for writing.... - */ + if ((chanTypePtr == &fileChannelType) || (chanTypePtr == &tcpChannelType) + || (strcmp(chanTypePtr->typeName, "pipe") == 0)) { + if (Tcl_GetChannelHandle(chan, + (forWriting ? TCL_WRITABLE : TCL_READABLE), (ClientData*) &fd) + == TCL_OK) { + + /* + * 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; + 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 * - unsupported type", - (char *) NULL); + "\" 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/contrib/tcl/unix/tclUnixEvent.c b/contrib/tcl/unix/tclUnixEvent.c new file mode 100644 index 0000000..24841ca --- /dev/null +++ b/contrib/tcl/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/contrib/tcl/unix/tclUnixFCmd.c b/contrib/tcl/unix/tclUnixFCmd.c new file mode 100644 index 0000000..51224e6 --- /dev/null +++ b/contrib/tcl/unix/tclUnixFCmd.c @@ -0,0 +1,1229 @@ +/* + * 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.29 97/06/16 16:28:25 + * + * 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; + } + + blockSize = srcStatBufPtr->st_blksize; + 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) { + endgrent(); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "could not get group for file \"", fileName, "\": ", + Tcl_PosixError(interp), (char *) NULL); + return TCL_ERROR; + } + + *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) { + endpwent(); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "could not get owner for file \"", fileName, "\": ", + Tcl_PosixError(interp), (char *) NULL); + return TCL_ERROR; + } + + *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/contrib/tcl/unix/tclUnixFile.c b/contrib/tcl/unix/tclUnixFile.c index cebd43b..3819ed5 100644 --- a/contrib/tcl/unix/tclUnixFile.c +++ b/contrib/tcl/unix/tclUnixFile.c @@ -9,7 +9,7 @@ * 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.38 96/04/18 08:43:51 + * SCCS: @(#) tclUnixFile.c 1.45 97/05/14 13:24:19 */ #include "tclInt.h" @@ -43,40 +43,6 @@ static void FreeExecutableName _ANSI_ARGS_((ClientData clientData)); /* *---------------------------------------------------------------------- * - * Tcl_WaitPid -- - * - * Implements the waitpid system call on Unix systems. - * - * Results: - * Result of calling waitpid. - * - * Side effects: - * Waits for a process to terminate. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_WaitPid(pid, statPtr, options) - int 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 result; - } - } -} - -/* - *---------------------------------------------------------------------- - * * FreeCurrentDir -- * * Frees the string stored in the currentDir variable. This routine @@ -99,6 +65,7 @@ FreeCurrentDir(clientData) if (currentDir != (char *) NULL) { ckfree(currentDir); currentDir = (char *) NULL; + currentDirExitHandlerSet = 0; } } @@ -205,7 +172,9 @@ TclGetCwd(interp) if (getcwd(buffer, MAXPATHLEN+1) == NULL) { if (interp != NULL) { if (errno == ERANGE) { - interp->result = "working directory name is too long"; + Tcl_SetResult(interp, + "working directory name is too long", + TCL_STATIC); } else { Tcl_AppendResult(interp, "error getting working directory name: ", @@ -223,227 +192,6 @@ TclGetCwd(interp) /* *---------------------------------------------------------------------- * - * TclOpenFile -- - * - * Implements a mechanism to open files on Unix systems. - * - * Results: - * The opened file. - * - * Side effects: - * May cause a file to be created on the file system. - * - *---------------------------------------------------------------------- - */ - -Tcl_File -TclOpenFile(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, 0600); - if (fd != -1) { - fcntl(fd, F_SETFD, FD_CLOEXEC); - return Tcl_GetFile((ClientData)fd, TCL_UNIX_FD); - } - return NULL; -} - -/* - *---------------------------------------------------------------------- - * - * TclCloseFile -- - * - * 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 -TclCloseFile(file) - Tcl_File file; /* The file to close. */ -{ - int type; - int fd; - int result; - - fd = (int) Tcl_GetFileInfo(file, &type); - if (type != TCL_UNIX_FD) { - panic("Tcl_CloseFile: unexpected file type"); - } - - /* - * Refuse to close the fds for stdin, stdout and stderr. - */ - - if ((fd == 0) || (fd == 1) || (fd == 2)) { - return 0; - } - - result = close(fd); - Tcl_DeleteFileHandler(file); - Tcl_FreeFile(file); - return result; -} - -/* - *---------------------------------------------------------------------- - * - * TclReadFile -- - * - * Implements a mechanism to read from files on Unix systems. Also - * simulates blocking behavior on non-blocking files when asked to. - * - * Results: - * The number of characters read from the specified file. - * - * Side effects: - * May consume characters from the file. - * - *---------------------------------------------------------------------- - */ - /* ARGSUSED */ -int -TclReadFile(file, shouldBlock, buf, toRead) - Tcl_File file; /* The file to read from. */ - int shouldBlock; /* Not used. */ - char *buf; /* The buffer to store input in. */ - int toRead; /* Number of characters to read. */ -{ - int type, fd; - - fd = (int) Tcl_GetFileInfo(file, &type); - if (type != TCL_UNIX_FD) { - panic("Tcl_ReadFile: unexpected file type"); - } - - return read(fd, buf, (size_t) toRead); -} - -/* - *---------------------------------------------------------------------- - * - * TclWriteFile -- - * - * Implements a mechanism to write to files on Unix systems. - * - * Results: - * The number of characters written to the specified file. - * - * Side effects: - * May produce characters on the file. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -int -TclWriteFile(file, shouldBlock, buf, toWrite) - Tcl_File file; /* The file to write to. */ - int shouldBlock; /* Not used. */ - char *buf; /* Where output is stored. */ - int toWrite; /* Number of characters to write. */ -{ - int type, fd; - - fd = (int) Tcl_GetFileInfo(file, &type); - if (type != TCL_UNIX_FD) { - panic("Tcl_WriteFile: unexpected file type"); - } - return write(fd, buf, (size_t) toWrite); -} - -/* - *---------------------------------------------------------------------- - * - * TclSeekFile -- - * - * Sets the file pointer on the indicated UNIX file. - * - * Results: - * The new position at which the file will be accessed, or -1 on - * failure. - * - * Side effects: - * May change the position at which subsequent operations access the - * file designated by the file. - * - *---------------------------------------------------------------------- - */ - -int -TclSeekFile(file, offset, whence) - Tcl_File file; /* The file to seek on. */ - int offset; /* How far to seek? */ - int whence; /* And from where to seek? */ -{ - int type, fd; - - fd = (int) Tcl_GetFileInfo(file, &type); - if (type != TCL_UNIX_FD) { - panic("Tcl_SeekFile: unexpected file type"); - } - - return lseek(fd, offset, whence); -} - -/* - *---------------------------------------------------------------------- - * - * TclCreateTempFile -- - * - * 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. - * - *---------------------------------------------------------------------- - */ - -Tcl_File -TclCreateTempFile(contents) - char *contents; /* String to write into temp file, or NULL. */ -{ - char fileName[L_tmpnam]; - Tcl_File file; - size_t length = (contents == NULL) ? 0 : strlen(contents); - - tmpnam(fileName); - file = TclOpenFile(fileName, O_RDWR|O_CREAT|O_TRUNC); - unlink(fileName); - - if ((file != NULL) && (length > 0)) { - int fd = (int)Tcl_GetFileInfo(file, NULL); - while (1) { - if (write(fd, contents, length) != -1) { - break; - } else if (errno != EINTR) { - close(fd); - Tcl_FreeFile(file); - return NULL; - } - } - lseek(fd, 0, SEEK_SET); - } - return file; -} - -/* - *---------------------------------------------------------------------- - * * Tcl_FindExecutable -- * * This procedure computes the absolute path name of the current @@ -467,6 +215,7 @@ Tcl_FindExecutable(argv0) char *name, *p, *cwd; Tcl_DString buffer; int length; + struct stat statBuf; Tcl_DStringInit(&buffer); if (tclExecutableName != NULL) { @@ -518,7 +267,9 @@ Tcl_FindExecutable(argv0) } } Tcl_DStringAppend(&buffer, argv0, -1); - if (access(Tcl_DStringValue(&buffer), X_OK) == 0) { + 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; } @@ -626,7 +377,8 @@ TclGetUserHome(name, bufferPtr) * Side effects: * None. * - *---------------------------------------------------------------------- */ + *---------------------------------------------------------------------- + */ int TclMatchFiles(interp, separators, dirPtr, pattern, tail) diff --git a/contrib/tcl/unix/tclUnixInit.c b/contrib/tcl/unix/tclUnixInit.c index a7206b6..930568b 100644 --- a/contrib/tcl/unix/tclUnixInit.c +++ b/contrib/tcl/unix/tclUnixInit.c @@ -8,14 +8,11 @@ * 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.14 96/07/10 15:45:24 + * SCCS: @(#) tclUnixInit.c 1.25 97/06/24 17:28:56 */ #include "tclInt.h" #include "tclPort.h" -#ifndef NO_UNAME -# include <sys/utsname.h> -#endif #if defined(__FreeBSD__) # include <floatingpoint.h> #endif @@ -27,12 +24,27 @@ #endif /* - * Default directory in which to look for libraries: + * 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 @@ -41,9 +53,11 @@ static char defaultLibraryDir[200] = TCL_LIBRARY; */ static char initScript[] = -"proc init {} {\n\ - global tcl_library tcl_version tcl_patchLevel env\n\ - rename init {}\n\ +"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\ @@ -60,16 +74,54 @@ static char initScript[] = lappend dirs $parentDir/library\n\ foreach i $dirs {\n\ set tcl_library $i\n\ - if ![catch {uplevel #0 source $i/init.tcl}] {\n\ - return\n\ + if {[file exists $i/init.tcl]} {\n\ + lappend tcl_pkgPath [file dirname $i]\n\ + if ![catch {uplevel #0 source $i/init.tcl} msg] {\n\ + return\n\ + } else {\n\ + append errors \"$i/init.tcl: $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\ + 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\ -init"; +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; +} /* *---------------------------------------------------------------------- @@ -97,10 +149,10 @@ TclPlatformInit(interp) struct utsname name; #endif int unameOK; - static int initialized = 0; 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 @@ -108,8 +160,25 @@ TclPlatformInit(interp) unameOK = 1; Tcl_SetVar2(interp, "tcl_platform", "os", name.sysname, TCL_GLOBAL_ONLY); - Tcl_SetVar2(interp, "tcl_platform", "osVersion", name.release, - 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); } @@ -121,6 +190,14 @@ TclPlatformInit(interp) } 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 @@ -175,3 +252,65 @@ Tcl_Init(interp) { 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/contrib/tcl/unix/tclUnixNotfy.c b/contrib/tcl/unix/tclUnixNotfy.c index 7dce634..74c0ffc 100644 --- a/contrib/tcl/unix/tclUnixNotfy.c +++ b/contrib/tcl/unix/tclUnixNotfy.c @@ -1,16 +1,17 @@ -/* +/* * tclUnixNotify.c -- * - * This file contains Unix-specific procedures for the notifier, - * which is the lowest-level part of the Tcl event loop. This file - * works together with ../generic/tclNotify.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 Sun Microsystems, Inc. + * 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.31 96/07/23 16:17:29 + * SCCS: @(#) tclUnixNotfy.c 1.41 97/06/02 16:45:24 */ #include "tclInt.h" @@ -18,176 +19,393 @@ #include <signal.h> /* - * The information below is used to provide read, write, and - * exception masks to select during calls to Tcl_DoOneEvent. + * 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. */ -static fd_mask checkMasks[3*MASK_SIZE]; +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_WatchFile. */ -static fd_mask readyMasks[3*MASK_SIZE]; + * 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. */ -static int numFdBits; /* Number of valid bits in checkMasks + 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; +} + /* - * Static routines in this file: + *---------------------------------------------------------------------- + * + * 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. + * + *---------------------------------------------------------------------- */ -static int MaskEmpty _ANSI_ARGS_((long *maskPtr)); +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_WatchFile -- + * Tcl_CreateFileHandler -- * - * Arrange for Tcl_DoOneEvent to include this file in the masks - * for the next call to select. This procedure is invoked by - * event sources, which are in turn invoked by Tcl_DoOneEvent - * before it invokes select. + * This procedure registers a file handler with the Xt notifier. * * Results: * None. * * Side effects: - * - * The notifier will generate a file event when the I/O channel - * given by fd next becomes ready in the way indicated by mask. - * If fd is already registered then the old mask will be replaced - * with the new one. Once the event is sent, the notifier will - * not send any more events about the fd until the next call to - * Tcl_NotifyFile. + * Creates a new file handler structure and registers one or more + * input procedures with Xt. * *---------------------------------------------------------------------- */ void -Tcl_WatchFile(file, mask) - Tcl_File file; /* Generic file handle for a stream. */ +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 to wait for - * in select. */ + * 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. */ { - int fd, type, index; - fd_mask bit; - - fd = (int) Tcl_GetFileInfo(file, &type); - - if (type != TCL_UNIX_FD) { - panic("Tcl_WatchFile: unexpected file type"); + FileHandler *filePtr; + int index, bit; + + if (!initialized) { + InitNotifier(); } - if (fd >= FD_SETSIZE) { - panic("Tcl_WatchFile can't handle file id %d", fd); + for (filePtr = notifier.firstFileHandlerPtr; filePtr != NULL; + filePtr = filePtr->nextPtr) { + if (filePtr->fd == fd) { + break; + } + } + if (filePtr == NULL) { + filePtr = (FileHandler*) ckalloc(sizeof(FileHandler)); + filePtr->fd = fd; + filePtr->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) { - checkMasks[index] |= bit; - } + notifier.checkMasks[index] |= bit; + } else { + notifier.checkMasks[index] &= ~bit; + } if (mask & TCL_WRITABLE) { - (checkMasks+MASK_SIZE)[index] |= bit; + (notifier.checkMasks+MASK_SIZE)[index] |= bit; + } else { + (notifier.checkMasks+MASK_SIZE)[index] &= ~bit; } if (mask & TCL_EXCEPTION) { - (checkMasks+2*(MASK_SIZE))[index] |= bit; + (notifier.checkMasks+2*(MASK_SIZE))[index] |= bit; + } else { + (notifier.checkMasks+2*(MASK_SIZE))[index] &= ~bit; } - if (numFdBits <= fd) { - numFdBits = fd+1; + if (notifier.numFdBits <= fd) { + notifier.numFdBits = fd+1; } } /* *---------------------------------------------------------------------- * - * Tcl_FileReady -- + * Tcl_DeleteFileHandler -- * - * Indicates what conditions (readable, writable, etc.) were - * present on a file the last time the notifier invoked select. - * This procedure is typically invoked by event sources to see - * if they should queue events. + * Cancel a previously-arranged callback arrangement for + * a file. * * Results: - * The return value is 0 if none of the conditions specified by mask - * was true for fd the last time the system checked. If any of the - * conditions were true, then the return value is a mask of those - * that were true. + * None. * * Side effects: - * None. + * If a callback was previously registered on file, remove it. * *---------------------------------------------------------------------- */ -int -Tcl_FileReady(file, mask) - Tcl_File file; /* Generic file handle for a stream. */ - int mask; /* OR'ed combination of TCL_READABLE, - * TCL_WRITABLE, and TCL_EXCEPTION: - * indicates conditions caller cares about. */ +void +Tcl_DeleteFileHandler(fd) + int fd; /* Stream id for which to remove callback procedure. */ { - int index, result, type, fd; - fd_mask bit; + FileHandler *filePtr, *prevPtr; + int index, bit, mask, i; + + if (!initialized) { + InitNotifier(); + } - fd = (int) Tcl_GetFileInfo(file, &type); - if (type != TCL_UNIX_FD) { - panic("Tcl_FileReady: unexpected file type"); + /* + * 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))); - result = 0; - if ((mask & TCL_READABLE) && (readyMasks[index] & bit)) { - result |= TCL_READABLE; + + if (filePtr->mask & TCL_READABLE) { + notifier.checkMasks[index] &= ~bit; } - if ((mask & TCL_WRITABLE) && ((readyMasks+MASK_SIZE)[index] & bit)) { - result |= TCL_WRITABLE; + 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--) { + mask = notifier.checkMasks[index] + | (notifier.checkMasks+MASK_SIZE)[index] + | (notifier.checkMasks+2*(MASK_SIZE))[index]; + if (mask) { + for (i = (NBBY*sizeof(fd_mask)); i > 0; i--) { + if (mask & (1 << (i-1))) { + break; + } + } + notifier.numFdBits = index * (NBBY*sizeof(fd_mask)) + i; + break; + } + } } - if ((mask & TCL_EXCEPTION) && ((readyMasks+(2*MASK_SIZE))[index] & bit)) { - result |= TCL_EXCEPTION; + + /* + * Clean up information in the callback record. + */ + + if (prevPtr == NULL) { + notifier.firstFileHandlerPtr = filePtr->nextPtr; + } else { + prevPtr->nextPtr = filePtr->nextPtr; } - return result; + ckfree((char *) filePtr); } /* *---------------------------------------------------------------------- * - * MaskEmpty -- + * FileHandlerEventProc -- * - * Returns nonzero if mask is empty (has no bits set). + * 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: - * Nonzero if the mask is empty, zero otherwise. + * 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: - * None + * Whatever the file handler's callback procedure does. * *---------------------------------------------------------------------- */ static int -MaskEmpty(maskPtr) - long *maskPtr; +FileHandlerEventProc(evPtr, flags) + Tcl_Event *evPtr; /* Event to service. */ + int flags; /* Flags that indicate what events to + * handle, such as TCL_FILE_EVENTS. */ { - long *runPtr, *tailPtr; - int found, sz; - - sz = 3 * ((MASK_SIZE) / sizeof(long)) * sizeof(fd_mask); - for (runPtr = maskPtr, tailPtr = maskPtr + sz, found = 0; - runPtr < tailPtr; - runPtr++) { - if (*runPtr != 0) { - found = 1; - break; - } + 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 !found; + return 1; } /* @@ -195,50 +413,55 @@ MaskEmpty(maskPtr) * * Tcl_WaitForEvent -- * - * This procedure does the lowest level wait for events in a - * platform-specific manner. It uses information provided by - * previous calls to Tcl_WatchFile, plus the timePtr argument, - * to determine what to wait for and how long to wait. + * 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: - * The return value is normally TCL_OK. However, if there are - * no events to wait for (e.g. no files and no timers) so that - * the procedure would block forever, then it returns TCL_ERROR. + * Returns -1 if the select would block forever, otherwise + * returns 0. * * Side effects: - * May put the process to sleep for a while, depending on timePtr. - * When this procedure returns, an event of interest to the application - * has probably, but not necessarily, occurred. + * Queues file events that are detected by the select. * *---------------------------------------------------------------------- */ int Tcl_WaitForEvent(timePtr) - Tcl_Time *timePtr; /* Specifies the maximum amount of time - * that this procedure should block before - * returning. The time is given as an - * interval, not an absolute wakeup time. - * NULL means block forever. */ + Tcl_Time *timePtr; /* Maximum block time, or NULL. */ { + FileHandler *filePtr; + FileHandlerEvent *fileEvPtr; struct timeval timeout, *timeoutPtr; - int numFound; + int bit, index, mask, numFound; - memcpy((VOID *) readyMasks, (VOID *) checkMasks, - 3*MASK_SIZE*sizeof(fd_mask)); - if (timePtr == NULL) { - if ((numFdBits == 0) || (MaskEmpty((long *) readyMasks))) { - return TCL_ERROR; - } - timeoutPtr = NULL; - } else { - timeoutPtr = &timeout; + 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; } - numFound = select(numFdBits, (SELECT_MASK *) &readyMasks[0], - (SELECT_MASK *) &readyMasks[MASK_SIZE], - (SELECT_MASK *) &readyMasks[2*MASK_SIZE], timeoutPtr); + + 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 @@ -246,77 +469,49 @@ Tcl_WaitForEvent(timePtr) */ if (numFound == -1) { - memset((VOID *) readyMasks, 0, 3*MASK_SIZE*sizeof(fd_mask)); + memset((VOID *) notifier.readyMasks, 0, 3*MASK_SIZE*sizeof(fd_mask)); } /* - * Reset the check masks in preparation for the next call to - * select. + * Queue all detected file events before returning. */ - numFdBits = 0; - memset((VOID *) checkMasks, 0, 3*MASK_SIZE*sizeof(fd_mask)); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_Sleep -- - * - * Delay execution for the specified number of milliseconds. - * - * Results: - * None. - * - * Side effects: - * Time passes. - * - *---------------------------------------------------------------------- - */ + 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; -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. - */ + 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; + } - 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; + if (!mask) { + continue; + } else { + numFound--; } /* - * Special note: must convert delay.tv_sec to int before comparing - * to zero, since delay.tv_usec is unsigned on some platforms. + * Don't bother to queue an event if the mask was previously + * non-zero since an event must still be on the queue. */ - if ((((int) delay.tv_sec) < 0) - || ((delay.tv_usec == 0) && (delay.tv_sec == 0))) { - break; + 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); } - (void) select(0, (SELECT_MASK *) 0, (SELECT_MASK *) 0, - (SELECT_MASK *) 0, &delay); - TclpGetTime(&before); + filePtr->readyMask = mask; } + return 0; } - diff --git a/contrib/tcl/unix/tclUnixPipe.c b/contrib/tcl/unix/tclUnixPipe.c index a7ff1b3..f6d90d7 100644 --- a/contrib/tcl/unix/tclUnixPipe.c +++ b/contrib/tcl/unix/tclUnixPipe.c @@ -1,25 +1,440 @@ /* - * tclUnixPipe.c -- This file implements the UNIX-specific exec pipeline - * functions. + * 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-1996 Sun Microsystems, Inc. + * 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.29 96/04/18 15:56:26 + * SCCS: @(#) tclUnixPipe.c 1.36 97/05/14 13:24:24 */ #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)((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 void RestoreSignals _ANSI_ARGS_((void)); -static int SetupStdFile _ANSI_ARGS_((Tcl_File file, int type)); +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. */ +{ + int fd; + + if (Tcl_GetChannelHandle(channel, direction, (ClientData *) &fd) + == TCL_OK) { + return MakeFile(fd); + } 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; +} /* *---------------------------------------------------------------------- @@ -116,7 +531,7 @@ RestoreSignals() static int SetupStdFile(file, type) - Tcl_File file; /* File to dup, or NULL. */ + TclFile file; /* File to dup, or NULL. */ int type; /* One of TCL_STDIN, TCL_STDOUT, TCL_STDERR */ { Tcl_Channel channel; @@ -143,11 +558,11 @@ SetupStdFile(file, type) if (!file) { channel = Tcl_GetStdChannel(type); if (channel) { - file = Tcl_GetChannelFile(channel, direction); + file = TclpMakeFile(channel, direction); } } if (file) { - fd = (int)Tcl_GetFileInfo(file, NULL); + fd = GetFd(file); if (fd != targetFd) { if (dup2(fd, targetFd) == -1) { return 0; @@ -179,318 +594,556 @@ SetupStdFile(file, type) /* *---------------------------------------------------------------------- * - * TclSpawnPipeline -- + * TclpCreateCommandChannel -- * - * Given an argc/argv array, instantiate a pipeline of processes - * as described by the argv. + * This function is called by the generic IO level to perform + * the platform specific channel initialization for a command + * channel. * * Results: - * The return value is 1 on success, 0 on error + * Returns a new channel or NULL on failure. * * Side effects: - * Processes and pipes are created. + * Allocates a new channel. * *---------------------------------------------------------------------- */ -int -TclSpawnPipeline(interp, pidPtr, numPids, argc, argv, inputFile, - outputFile, errorFile, intIn, finalOut) - Tcl_Interp *interp; /* Interpreter in which to process pipeline. */ - int *pidPtr; /* Array of pids which are created. */ - int *numPids; /* Number of pids created. */ - int argc; /* Number of entries in argv. */ - char **argv; /* Array of strings describing commands in - * pipeline plus I/O redirection with <, - * <<, >, etc. argv[argc] must be NULL. */ - Tcl_File inputFile; /* If >=0, gives file id to use as input for - * first process in pipeline (specified via < - * or <@). */ - Tcl_File outputFile; /* Writable file id for output from last - * command in pipeline (could be file or - * pipe). NULL means use stdout. */ - Tcl_File errorFile; /* Writable file id for error output from all - * commands in the pipeline. NULL means use - * stderr */ - char *intIn; /* File name for initial input (for Win32s). */ - char *finalOut; /* File name for final output (for Win32s). */ -{ - int firstArg, lastArg; - int pid, count; - Tcl_DString buffer; - char *execName; - char errSpace[200]; - Tcl_File pipeIn, errPipeIn, errPipeOut; - int joinThisError; - Tcl_File curOutFile = NULL, curInFile; - - Tcl_DStringInit(&buffer); - pipeIn = errPipeIn = errPipeOut = NULL; - curInFile = inputFile; +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; - for (firstArg = 0; firstArg < argc; firstArg = lastArg+1) { + statePtr->inFile = readFile; + statePtr->outFile = writeFile; + statePtr->errorFile = errorFile; + statePtr->numPids = numPids; + statePtr->pidPtr = pidPtr; + statePtr->isNonBlocking = 0; - /* - * Convert the program name into native form. - */ + 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. + */ - Tcl_DStringFree(&buffer); - execName = Tcl_TranslateFileName(interp, argv[firstArg], &buffer); - if (execName == NULL) { - goto error; - } + if (readFile) { + channelId = GetFd(readFile); + } else if (writeFile) { + channelId = GetFd(writeFile); + } else if (errorFile) { + channelId = GetFd(errorFile); + } else { + channelId = 0; + } - /* - * Find the end of the current segment of the pipeline. - */ + /* + * 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". + */ - joinThisError = 0; - for (lastArg = firstArg; lastArg < argc; lastArg++) { - if (argv[lastArg][0] == '|') { - if (argv[lastArg][1] == 0) { - break; - } - if ((argv[lastArg][1] == '&') && (argv[lastArg][2] == 0)) { - joinThisError = 1; - break; - } - } - } - argv[lastArg] = NULL; + 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. + * + *---------------------------------------------------------------------- + */ - /* - * If this is the last segment, use the specified outputFile. - * Otherwise create an intermediate pipe. - */ +void +TclGetAndDetachPids(interp, chan) + Tcl_Interp *interp; + Tcl_Channel chan; +{ + PipeState *pipePtr; + Tcl_ChannelType *chanTypePtr; + int i; + char buf[20]; - if (lastArg == argc) { - curOutFile = outputFile; - } else { - if (TclCreatePipe(&pipeIn, &curOutFile) == 0) { - Tcl_AppendResult(interp, "couldn't create pipe: ", - Tcl_PosixError(interp), (char *) NULL); - goto error; - } - } + /* + * Punt if the channel is not a command channel. + */ - /* - * Create a pipe that the child can use to return error - * information if anything goes wrong. - */ + chanTypePtr = Tcl_GetChannelType(chan); + if (chanTypePtr != &pipeChannelType) { + return; + } - if (TclCreatePipe(&errPipeIn, &errPipeOut) == 0) { - Tcl_AppendResult(interp, "couldn't create pipe: ", - Tcl_PosixError(interp), (char *) NULL); - goto error; - } + 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. + * + *---------------------------------------------------------------------- + */ - pid = vfork(); - if (pid == 0) { + /* 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; - /* - * Set up stdio file handles for the child process. - */ +#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 */ - if (!SetupStdFile(curInFile, TCL_STDIN) - || !SetupStdFile(curOutFile, 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); - TclWriteFile(errPipeOut, 1, errSpace, (int) strlen(errSpace)); - _exit(1); - } +#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. + * + *---------------------------------------------------------------------- + */ - /* - * Close the input side of the error pipe. - */ + /* 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; - RestoreSignals(); - execvp(execName, &argv[firstArg]); - sprintf(errSpace, "%dcouldn't execute \"%.150s\": ", errno, - argv[firstArg]); - TclWriteFile(errPipeOut, 1, errSpace, (int) strlen(errSpace)); - _exit(1); + errorCode = 0; + result = 0; + pipePtr = (PipeState *) instanceData; + if (pipePtr->inFile) { + if (TclpCloseFile(pipePtr->inFile) < 0) { + errorCode = errno; } - Tcl_DStringFree(&buffer); - if (pid == -1) { - Tcl_AppendResult(interp, "couldn't fork child process: ", - Tcl_PosixError(interp), (char *) NULL); - goto error; + } + if (pipePtr->outFile) { + if ((TclpCloseFile(pipePtr->outFile) < 0) && (errorCode == 0)) { + errorCode = errno; } + } + if (pipePtr->isNonBlocking || TclInExit()) { + /* - * Add the child process to the list of those to be reaped. - * Note: must do it now, so that the process will be reaped even if - * an error occurs during its startup. - */ - - pidPtr[*numPids] = pid; - (*numPids)++; - - /* - * Read back from the error pipe to see if the child startup - * up OK. The info in the pipe (if any) consists of a decimal - * errno value followed by an error message. - */ - - TclCloseFile(errPipeOut); - errPipeOut = NULL; - - count = TclReadFile(errPipeIn, 1, 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; - } - TclCloseFile(errPipeIn); - errPipeIn = NULL; + * 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 { + /* - * Close off our copies of file descriptors that were set up for - * this child, then set up the input for the next child. - */ + * Wrap the error file into a channel and give it to the cleanup + * routine. + */ - if (curInFile && (curInFile != inputFile)) { - TclCloseFile(curInFile); - } - curInFile = pipeIn; - pipeIn = NULL; + if (pipePtr->errorFile) { + errChan = Tcl_MakeFileChannel( + (ClientData) GetFd(pipePtr->errorFile), TCL_READABLE); + } else { + errChan = NULL; + } + result = TclCleanupChildren(interp, pipePtr->numPids, pipePtr->pidPtr, + errChan); + } - if (curOutFile && (curOutFile != outputFile)) { - TclCloseFile(curOutFile); - } - curOutFile = NULL; + if (pipePtr->numPids != 0) { + ckfree((char *) pipePtr->pidPtr); } - return 1; + 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; + /* - * An error occured, so we need to clean up any open pipes. + * 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. */ -error: - Tcl_DStringFree(&buffer); - if (errPipeIn) { - TclCloseFile(errPipeIn); - } - if (errPipeOut) { - TclCloseFile(errPipeOut); + bytesRead = read(GetFd(psPtr->inFile), buf, (size_t) toRead); + if (bytesRead > -1) { + return bytesRead; } - if (pipeIn) { - TclCloseFile(pipeIn); + *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; } - if (curOutFile && (curOutFile != outputFile)) { - TclCloseFile(curOutFile); + *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 (curInFile && (curInFile != inputFile)) { - TclCloseFile(curInFile); + 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)); + } } - return 0; } /* *---------------------------------------------------------------------- * - * TclCreatePipe -- + * PipeGetHandleProc -- * - * Creates a pipe - simply calls the pipe() function. + * Called from Tcl_GetChannelHandle to retrieve OS handles from + * inside a command pipeline based channel. * * Results: - * Returns 1 on success, 0 on failure. + * Returns TCL_OK with the fd in handlePtr, or TCL_ERROR if + * there is no handle for the specified direction. * * Side effects: - * Creates a pipe. + * None. * *---------------------------------------------------------------------- */ -int -TclCreatePipe(readPipe, writePipe) - Tcl_File *readPipe; /* Location to store file handle for - * read side of pipe. */ - Tcl_File *writePipe; /* Location to store file handle for - * write side of pipe. */ + +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. */ { - int pipeIds[2]; + PipeState *psPtr = (PipeState *) instanceData; - if (pipe(pipeIds) != 0) { - return 0; + 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. + * + *---------------------------------------------------------------------- + */ - fcntl(pipeIds[0], F_SETFD, FD_CLOEXEC); - fcntl(pipeIds[1], F_SETFD, FD_CLOEXEC); +Tcl_Pid +Tcl_WaitPid(pid, statPtr, options) + Tcl_Pid pid; + int *statPtr; + int options; +{ + int result; + pid_t real_pid; - *readPipe = Tcl_GetFile((ClientData)pipeIds[0], TCL_UNIX_FD); - *writePipe = Tcl_GetFile((ClientData)pipeIds[1], TCL_UNIX_FD); - return 1; + real_pid = (pid_t) pid; + while (1) { + result = (int) waitpid(real_pid, statPtr, options); + if ((result != -1) || (errno != EINTR)) { + return (Tcl_Pid) result; + } + } } /* *---------------------------------------------------------------------- * - * Tcl_CreatePipeline -- + * Tcl_PidObjCmd -- * - * This function is a compatibility wrapper for TclCreatePipeline. - * It is only available under Unix, and may be removed from later - * versions. + * This procedure is invoked to process the "pid" Tcl command. + * See the user documentation for details on what it does. * * Results: - * Same as TclCreatePipeline. + * A standard Tcl result. * * Side effects: - * Same as TclCreatePipeline. + * See the user documentation. * *---------------------------------------------------------------------- */ + /* ARGSUSED */ int -Tcl_CreatePipeline(interp, argc, argv, pidArrayPtr, inPipePtr, - outPipePtr, errFilePtr) - Tcl_Interp *interp; - int argc; - char **argv; - int **pidArrayPtr; - int *inPipePtr; - int *outPipePtr; - int *errFilePtr; +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_File inFile, outFile, errFile; - int result; - - result = TclCreatePipeline(interp, argc, argv, pidArrayPtr, - (inPipePtr ? &inFile : NULL), - (outPipePtr ? &outFile : NULL), - (errFilePtr ? &errFile : NULL)); + Tcl_Channel chan; + Tcl_ChannelType *chanTypePtr; + PipeState *pipePtr; + int i; + Tcl_Obj *resultPtr, *longObjPtr; - if (inPipePtr) { - if (inFile) { - *inPipePtr = (int) Tcl_GetFileInfo(inFile, NULL); - Tcl_FreeFile(inFile); - } else { - *inPipePtr = -1; - } + if (objc > 2) { + Tcl_WrongNumArgs(interp, 1, objv, "?channelId?"); + return TCL_ERROR; } - if (outPipePtr) { - if (outFile) { - *outPipePtr = (int) Tcl_GetFileInfo(outFile, NULL); - Tcl_FreeFile(outFile); - } else { - *outPipePtr = -1; + 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; } - } - if (errFilePtr) { - if (errFile) { - *errFilePtr = (int) Tcl_GetFileInfo(errFile, NULL); - Tcl_FreeFile(errFile); - } else { - *errFilePtr = -1; + 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 result; + return TCL_OK; } diff --git a/contrib/tcl/unix/tclUnixPort.h b/contrib/tcl/unix/tclUnixPort.h index bbf1432..c0d590a 100644 --- a/contrib/tcl/unix/tclUnixPort.h +++ b/contrib/tcl/unix/tclUnixPort.h @@ -19,7 +19,7 @@ * 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.34 96/07/23 16:17:47 + * SCCS: @(#) tclUnixPort.h 1.47 97/05/22 10:57:36 */ #ifndef _TCLUNIXPORT @@ -69,6 +69,21 @@ #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 @@ -76,12 +91,43 @@ */ #include <sys/socket.h> /* struct sockaddr, SOCK_STREAM, ... */ -#include <sys/utsname.h> /* uname system call. */ +#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. */ @@ -102,6 +148,16 @@ #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: */ @@ -417,5 +473,15 @@ extern double strtod(); #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/contrib/tcl/unix/tclUnixSock.c b/contrib/tcl/unix/tclUnixSock.c index e5d293b..4301889 100644 --- a/contrib/tcl/unix/tclUnixSock.c +++ b/contrib/tcl/unix/tclUnixSock.c @@ -8,7 +8,7 @@ * 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.5 96/04/04 15:28:39 + * SCCS: @(#) tclUnixSock.c 1.6 96/08/08 08:48:51 */ #include "tcl.h" @@ -33,7 +33,8 @@ static int hostnameInited = 0; * Get the network name for this machine, in a system dependent way. * * Results: - * A string containing the network name for this machine. + * A string containing the network name for this machine, or + * an empty string if we can't figure out the name. * * Side effects: * None. @@ -44,13 +45,16 @@ static int hostnameInited = 0; char * Tcl_GetHostName() { +#ifndef NO_UNAME struct utsname u; struct hostent *hp; +#endif if (hostnameInited) { return hostname; } - + +#ifndef NO_UNAME if (uname(&u) > -1) { hp = gethostbyname(u.nodename); if (hp != NULL) { @@ -61,5 +65,17 @@ Tcl_GetHostName() hostnameInited = 1; return hostname; } - return (char *) NULL; +#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/contrib/tcl/unix/tclUnixTest.c b/contrib/tcl/unix/tclUnixTest.c index 1fc95e6..67717d0 100644 --- a/contrib/tcl/unix/tclUnixTest.c +++ b/contrib/tcl/unix/tclUnixTest.c @@ -8,21 +8,30 @@ * 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.1 96/03/26 12:44:30 + * SCCS: @(#) tclUnixTest.c 1.4 97/05/14 13:24:29 */ #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 { - Tcl_File readFile; /* File handle for reading from the + TclFile readFile; /* File handle for reading from the * pipe. NULL means pipe doesn't exist yet. */ - Tcl_File writeFile; /* File handle for writing from the + 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 @@ -43,6 +52,8 @@ 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)); @@ -70,6 +81,8 @@ TclplatformtestInit(interp) { 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; @@ -104,15 +117,13 @@ TestfilehandlerCmd(clientData, interp, argc, argv) int i, mask, timeout; static int initialized = 0; char buffer[4000]; - Tcl_File file; + TclFile file; /* * NOTE: When we make this code work on Windows also, the following * variable needs to be made Unix-only. */ - int fd; - if (!initialized) { for (i = 0; i < MAX_PIPES; i++) { testPipes[i].readFile = NULL; @@ -140,26 +151,10 @@ TestfilehandlerCmd(clientData, interp, argc, argv) if (strcmp(argv[1], "close") == 0) { for (i = 0; i < MAX_PIPES; i++) { if (testPipes[i].readFile != NULL) { - Tcl_DeleteFileHandler(testPipes[i].readFile); - - /* - * NOTE: Unix specific code below. - */ - - fd = (int) Tcl_GetFileInfo(testPipes[i].readFile, NULL); - close(fd); - Tcl_FreeFile(testPipes[i].readFile); - + TclpCloseFile(testPipes[i].readFile); testPipes[i].readFile = NULL; - Tcl_DeleteFileHandler(testPipes[i].writeFile); - - /* - * NOTE: Unix specific code below. - */ - - fd = (int) Tcl_GetFileInfo(testPipes[i].writeFile, NULL); - Tcl_FreeFile(testPipes[i].writeFile); - close(fd); + TclpCloseFile(testPipes[i].writeFile); + testPipes[i].writeFile = NULL; } } } else if (strcmp(argv[1], "clear") == 0) { @@ -170,13 +165,15 @@ TestfilehandlerCmd(clientData, interp, argc, argv) } 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(interp->result, "%d %d", pipePtr->readCount, - pipePtr->writeCount); + 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 \"", @@ -185,18 +182,17 @@ TestfilehandlerCmd(clientData, interp, argc, argv) return TCL_ERROR; } if (pipePtr->readFile == NULL) { - if (!TclCreatePipe(&pipePtr->readFile, &pipePtr->writeFile)) { + 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((int)Tcl_GetFileInfo(pipePtr->readFile, NULL), - F_SETFL, O_NONBLOCK); - fcntl((int)Tcl_GetFileInfo(pipePtr->writeFile, NULL), - F_SETFL, O_NONBLOCK); + fcntl(GetFd(pipePtr->readFile), F_SETFL, O_NONBLOCK); + fcntl(GetFd(pipePtr->writeFile), F_SETFL, O_NONBLOCK); #else - interp->result = "can't make pipes non-blocking"; + Tcl_SetResult(interp, "can't make pipes non-blocking", + TCL_STATIC); return TCL_ERROR; #endif } @@ -204,12 +200,12 @@ TestfilehandlerCmd(clientData, interp, argc, argv) pipePtr->writeCount = 0; if (strcmp(argv[3], "readable") == 0) { - Tcl_CreateFileHandler(pipePtr->readFile, TCL_READABLE, + Tcl_CreateFileHandler(GetFd(pipePtr->readFile), TCL_READABLE, TestFileHandlerProc, (ClientData) pipePtr); } else if (strcmp(argv[3], "off") == 0) { - Tcl_DeleteFileHandler(pipePtr->readFile); + Tcl_DeleteFileHandler(GetFd(pipePtr->readFile)); } else if (strcmp(argv[3], "disabled") == 0) { - Tcl_CreateFileHandler(pipePtr->readFile, 0, + Tcl_CreateFileHandler(GetFd(pipePtr->readFile), 0, TestFileHandlerProc, (ClientData) pipePtr); } else { Tcl_AppendResult(interp, "bad read mode \"", argv[3], "\"", @@ -217,12 +213,12 @@ TestfilehandlerCmd(clientData, interp, argc, argv) return TCL_ERROR; } if (strcmp(argv[4], "writable") == 0) { - Tcl_CreateFileHandler(pipePtr->writeFile, TCL_WRITABLE, + Tcl_CreateFileHandler(GetFd(pipePtr->writeFile), TCL_WRITABLE, TestFileHandlerProc, (ClientData) pipePtr); } else if (strcmp(argv[4], "off") == 0) { - Tcl_DeleteFileHandler(pipePtr->writeFile); + Tcl_DeleteFileHandler(GetFd(pipePtr->writeFile)); } else if (strcmp(argv[4], "disabled") == 0) { - Tcl_CreateFileHandler(pipePtr->writeFile, 0, + Tcl_CreateFileHandler(GetFd(pipePtr->writeFile), 0, TestFileHandlerProc, (ClientData) pipePtr); } else { Tcl_AppendResult(interp, "bad read mode \"", argv[4], "\"", @@ -236,12 +232,7 @@ TestfilehandlerCmd(clientData, interp, argc, argv) return TCL_ERROR; } - /* - * NOTE: Unix specific code below. - */ - - fd = (int) Tcl_GetFileInfo(pipePtr->readFile, NULL); - while (read(fd, buffer, 4000) > 0) { + while (read(GetFd(pipePtr->readFile), buffer, 4000) > 0) { /* Empty loop body. */ } } else if (strcmp(argv[1], "fill") == 0) { @@ -251,29 +242,22 @@ TestfilehandlerCmd(clientData, interp, argc, argv) return TCL_ERROR; } - /* - * NOTE: Unix specific code below. - */ - - fd = (int) Tcl_GetFileInfo(pipePtr->writeFile, NULL); memset((VOID *) buffer, 'a', 4000); - while (write(fd, buffer, 4000) > 0) { + 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; } - /* - * NOTE: Unix specific code below. - */ - - fd = (int) Tcl_GetFileInfo(pipePtr->writeFile, NULL); memset((VOID *) buffer, 'b', 10); - sprintf(interp->result, "%d", write(fd, buffer, 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) { @@ -298,7 +282,7 @@ TestfilehandlerCmd(clientData, interp, argc, argv) if (Tcl_GetInt(interp, argv[4], &timeout) != TCL_OK) { return TCL_ERROR; } - i = TclWaitForFile(file, mask, timeout); + i = TclUnixWaitForFile(GetFd(file), mask, timeout); if (i & TCL_READABLE) { Tcl_AppendElement(interp, "readable"); } @@ -335,6 +319,73 @@ static void TestFileHandlerProc(clientData, mask) /* *---------------------------------------------------------------------- * + * 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; + + 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*) &fd) != TCL_OK) { + Tcl_SetResult(interp, "couldn't get channel file", TCL_STATIC); + return TCL_ERROR; + } + 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 diff --git a/contrib/tcl/unix/tclXtTest.c b/contrib/tcl/unix/tclXtTest.c new file mode 100644 index 0000000..bb23256 --- /dev/null +++ b/contrib/tcl/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.1 97/03/24 14:30:42 + */ + +#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) { + XtProcessEvent(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; +} |
