diff options
Diffstat (limited to 'unix')
| -rw-r--r-- | unix/Makefile.in | 207 | ||||
| -rw-r--r-- | unix/README | 22 | ||||
| -rw-r--r-- | unix/configure.in | 140 | ||||
| -rw-r--r-- | unix/dltest/Makefile.in | 5 | ||||
| -rw-r--r-- | unix/dltest/configure.in | 4 | ||||
| -rw-r--r-- | unix/dltest/pkge.c | 6 | ||||
| -rw-r--r-- | unix/dltest/pkgf.c | 5 | ||||
| -rw-r--r-- | unix/mkLinks | 276 | ||||
| -rw-r--r-- | unix/porting.notes | 417 | ||||
| -rw-r--r-- | unix/tclAppInit.c | 29 | ||||
| -rw-r--r-- | unix/tclLoadAix.c | 6 | ||||
| -rw-r--r-- | unix/tclLoadAout.c | 69 | ||||
| -rw-r--r-- | unix/tclLoadDl.c | 82 | ||||
| -rw-r--r-- | unix/tclLoadDld.c | 47 | ||||
| -rw-r--r-- | unix/tclLoadNext.c | 41 | ||||
| -rw-r--r-- | unix/tclLoadOSF.c | 42 | ||||
| -rw-r--r-- | unix/tclLoadShl.c | 57 | ||||
| -rw-r--r-- | unix/tclMtherr.c | 13 | ||||
| -rw-r--r-- | unix/tclUnixChan.c | 558 | ||||
| -rw-r--r-- | unix/tclUnixEvent.c | 4 | ||||
| -rw-r--r-- | unix/tclUnixFCmd.c | 711 | ||||
| -rw-r--r-- | unix/tclUnixFile.c | 603 | ||||
| -rw-r--r-- | unix/tclUnixInit.c | 508 | ||||
| -rw-r--r-- | unix/tclUnixNotfy.c | 643 | ||||
| -rw-r--r-- | unix/tclUnixPipe.c | 103 | ||||
| -rw-r--r-- | unix/tclUnixPort.h | 136 | ||||
| -rw-r--r-- | unix/tclUnixSock.c | 38 | ||||
| -rw-r--r-- | unix/tclUnixTest.c | 114 | ||||
| -rw-r--r-- | unix/tclUnixThrd.c | 682 | ||||
| -rw-r--r-- | unix/tclUnixThrd.h | 21 | ||||
| -rw-r--r-- | unix/tclUnixTime.c | 17 | ||||
| -rw-r--r-- | unix/tclXtTest.c | 4 |
32 files changed, 3939 insertions, 1671 deletions
diff --git a/unix/Makefile.in b/unix/Makefile.in index 0c51267..be01ab2 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -5,7 +5,7 @@ # "autoconf" program (constructs like "@foo@" will get replaced in the # actual Makefile. # -# RCS: @(#) $Id: Makefile.in,v 1.20 1999/03/11 21:47:39 stanton Exp $ +# RCS: @(#) $Id: Makefile.in,v 1.21 1999/04/16 00:48:03 stanton Exp $ # Current Tcl version; used in various names. @@ -86,7 +86,8 @@ CFLAGS_OPTIMIZE = @CFLAGS_OPTIMIZE@ #CFLAGS = $(CFLAGS_DEBUG) #CFLAGS = $(CFLAGS_OPTIMIZE) #CFLAGS = $(CFLAGS_DEBUG) $(CFLAGS_OPTIMIZE) -CFLAGS = $(@CFLAGS_DEFAULT@) +CFLAGS = @CFLAGS@ + # To disable ANSI-C procedure prototypes reverse the comment characters # on the following lines: @@ -119,7 +120,7 @@ GENERIC_FLAGS = #GENERIC_FLAGS = -DTCL_GENERIC_ONLY UNIX_OBJS = tclMtherr.o tclUnixChan.o tclUnixEvent.o tclUnixFCmd.o \ tclUnixFile.o tclUnixPipe.o tclUnixSock.o \ - tclUnixTime.o tclUnixInit.o + tclUnixTime.o tclUnixInit.o tclUnixThrd.o #UNIX_OBJS = NOTIFY_OBJS = tclUnixNotfy.o #NOTIFY_OBJS = @@ -146,6 +147,11 @@ COMPILE_DEBUG_FLAGS = #COMPILE_DEBUG_FLAGS = -DTCL_COMPILE_STATS #COMPILE_DEBUG_FLAGS = -DTCL_COMPILE_DEBUG -DTCL_COMPILE_STATS +# To compile without backward compatibility and deprecated code +# uncomment the following +NO_DEPRECATED_FLAGS= +#NO_DEPRECATED_FLAGS= -DTCL_NO_DEPRECATED + # Some versions of make, like SGI's, use the following variable to # determine which shell to use for executing commands: SHELL = /bin/sh @@ -212,8 +218,12 @@ 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@ +UNIX_DIR = $(TOP_DIR)/unix +# Must be absolute because of the cd dltest $(DLTEST_DIR)/configure below. +DLTEST_DIR = @TCL_SRC_DIR@/unix/dltest +# Must be absolute to so the corresponding tcltest's tcl_library is absolute. +TCL_BUILDTIME_LIBRARY= @TCL_SRC_DIR@/library + CC = @CC@ #---------------------------------------------------------------- @@ -226,7 +236,8 @@ CC = @CC@ CC_SWITCHES = ${CFLAGS} ${CFLAGS_WARNING} ${TCL_SHLIB_CFLAGS} \ -I${GENERIC_DIR} -I${SRC_DIR} \ ${AC_FLAGS} ${MATH_FLAGS} ${GENERIC_FLAGS} ${PROTO_FLAGS} ${MEM_DEBUG_FLAGS} \ -${COMPILE_DEBUG_FLAGS} ${ENV_FLAGS} -DTCL_SHLIB_EXT=\"${SHLIB_SUFFIX}\" +${COMPILE_DEBUG_FLAGS} ${NO_DEPRECATED_FLAGS} ${ENV_FLAGS} \ +-DTCL_SHLIB_EXT=\"${SHLIB_SUFFIX}\" STUB_CC_SWITCHES = ${CFLAGS} ${CFLAGS_WARNING} ${SHLIB_CFLAGS} \ -I${GENERIC_DIR} -I${SRC_DIR} \ @@ -238,32 +249,32 @@ LIBS = @DL_LIBS@ @LIBS@ $(MATH_LIBS) -lc DEPEND_SWITCHES = ${CFLAGS} -I${GENERIC_DIR} -I${SRC_DIR} \ ${AC_FLAGS} ${MATH_FLAGS} \ ${GENERIC_FLAGS} ${PROTO_FLAGS} ${MEM_DEBUG_FLAGS} \ --DTCL_SHLIB_EXT=\"${SHLIB_SUFFIX}\" $(STUB_FLAGS) +-DTCL_SHLIB_EXT=\"${SHLIB_SUFFIX}\" TCLSH_OBJS = tclAppInit.o TCLTEST_OBJS = tclTestInit.o tclTest.o tclTestObj.o tclTestProcBodyObj.o \ - tclUnixTest.o + tclThreadTest.o tclUnixTest.o XTTEST_OBJS = tclTest.o tclTestObj.o tclUnixTest.o tclXtNotify.o \ tclXtTest.o xtTestInit.o -GENERIC_OBJS = regexp.o tclAlloc.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 tclPanic.o tclParse.o tclPipe.o tclPkg.o \ - tclPosixStr.o tclPreserve.o tclProc.o tclResolve.o tclStringObj.o \ - tclStubInit.o tclTimer.o tclUtil.o tclVar.o +GENERIC_OBJS = regcomp.o regexec.o regfree.o regerror.o tclAlloc.o \ + tclAsync.o tclBasic.o tclBinary.o \ + tclCkalloc.o tclClock.o tclCmdAH.o tclCmdIL.o tclCmdMZ.o \ + tclCompCmds.o tclCompExpr.o tclCompile.o tclDate.o tclEncoding.o \ + tclEnv.o tclEvent.o tclExecute.o tclFCmd.o tclFileName.o tclGet.o \ + tclHash.o tclHistory.o tclIndexObj.o tclInterp.o tclIO.o \ + tclIOCmd.o tclIOSock.o tclIOUtil.o tclLink.o tclListObj.o \ + tclLiteral.o tclLoad.o tclMain.o tclNamesp.o tclNotify.o \ + tclObj.o tclPanic.o tclParse.o tclParseExpr.o tclPipe.o \ + tclPkg.o tclPosixStr.o tclPreserve.o tclProc.o tclRegexp.o \ + tclResolve.o tclResult.o tclScan.o tclStringObj.o tclThread.o \ + tclStubInit.o tclStubLib.o tclTimer.o tclUtf.o tclUtil.o tclVar.o -STUB_LIB_OBJS = tclIntPlatStubs.o tclIntStubs.o tclPlatStubs.o tclStubLib.o \ - tclStubs.o ${COMPAT_OBJS} +STUB_LIB_OBJS = tclStubLib.o ${COMPAT_OBJS} -OBJS = ${GENERIC_OBJS} ${UNIX_OBJS} ${NOTIFY_OBJS} ${COMPAT_OBJS} \ - @DL_OBJS@ +OBJS = ${GENERIC_OBJS} ${UNIX_OBJS} ${NOTIFY_OBJS} ${COMPAT_OBJS} @DL_OBJS@ TCL_DECLS = \ $(GENERIC_DIR)/tcl.decls \ @@ -281,7 +292,10 @@ GENERIC_HDRS = \ $(GENERIC_DIR)/tclRegexp.h GENERIC_SRCS = \ - $(GENERIC_DIR)/regexp.c \ + $(GENERIC_DIR)/regcomp.c \ + $(GENERIC_DIR)/regexec.c \ + $(GENERIC_DIR)/regfree.c \ + $(GENERIC_DIR)/regerror.c \ $(GENERIC_DIR)/tclAlloc.c \ $(GENERIC_DIR)/tclAsync.c \ $(GENERIC_DIR)/tclBasic.c \ @@ -291,9 +305,11 @@ GENERIC_SRCS = \ $(GENERIC_DIR)/tclCmdAH.c \ $(GENERIC_DIR)/tclCmdIL.c \ $(GENERIC_DIR)/tclCmdMZ.c \ + $(GENERIC_DIR)/tclCompCmds.c \ $(GENERIC_DIR)/tclCompExpr.c \ $(GENERIC_DIR)/tclCompile.c \ $(GENERIC_DIR)/tclDate.c \ + $(GENERIC_DIR)/tclEncoding.c \ $(GENERIC_DIR)/tclEnv.c \ $(GENERIC_DIR)/tclEvent.c \ $(GENERIC_DIR)/tclExecute.c \ @@ -310,33 +326,36 @@ GENERIC_SRCS = \ $(GENERIC_DIR)/tclIOUtil.c \ $(GENERIC_DIR)/tclLink.c \ $(GENERIC_DIR)/tclListObj.c \ + $(GENERIC_DIR)/tclLiteral.c \ $(GENERIC_DIR)/tclLoad.c \ $(GENERIC_DIR)/tclMain.c \ $(GENERIC_DIR)/tclNamesp.c \ $(GENERIC_DIR)/tclNotify.c \ $(GENERIC_DIR)/tclObj.c \ $(GENERIC_DIR)/tclParse.c \ + $(GENERIC_DIR)/tclParseExpr.c \ $(GENERIC_DIR)/tclPipe.c \ $(GENERIC_DIR)/tclPkg.c \ $(GENERIC_DIR)/tclPosixStr.c \ $(GENERIC_DIR)/tclPreserve.c \ $(GENERIC_DIR)/tclProc.c \ + $(GENERIC_DIR)/tclRegexp.c \ $(GENERIC_DIR)/tclResolve.c \ + $(GENERIC_DIR)/tclResult.c \ + $(GENERIC_DIR)/tclScan.c \ $(GENERIC_DIR)/tclStubInit.c \ + $(GENERIC_DIR)/tclStubLib.c \ $(GENERIC_DIR)/tclStringObj.c \ $(GENERIC_DIR)/tclTest.c \ $(GENERIC_DIR)/tclTestObj.c \ $(GENERIC_DIR)/tclTestProcBodyObj.c \ + $(GENERIC_DIR)/tclThread.c \ $(GENERIC_DIR)/tclTimer.c \ $(GENERIC_DIR)/tclUtil.c \ $(GENERIC_DIR)/tclVar.c STUB_SRCS = \ - $(GENERIC_DIR)/tclIntPlatStubs.c \ - $(GENERIC_DIR)/tclIntStubs.c \ - $(GENERIC_DIR)/tclPlatStubs.c \ - $(GENERIC_DIR)/tclStubLib.c \ - $(GENERIC_DIR)/tclStubs.c + $(GENERIC_DIR)/tclStubLib.c UNIX_HDRS = \ $(UNIX_DIR)/tclUnixPort.h @@ -352,6 +371,7 @@ UNIX_SRCS = \ $(UNIX_DIR)/tclUnixPipe.c \ $(UNIX_DIR)/tclUnixSock.c \ $(UNIX_DIR)/tclUnixTest.c \ + $(UNIX_DIR)/tclUnixThrd.c \ $(UNIX_DIR)/tclUnixTime.c \ $(UNIX_DIR)/tclUnixInit.c @@ -419,14 +439,14 @@ xttest: ${XTTEST_OBJS} ${GENERIC_OBJS} ${UNIX_OBJS} ${COMPAT_OBJS} \ test: tcltest LD_LIBRARY_PATH=`pwd`:${LD_LIBRARY_PATH}; export LD_LIBRARY_PATH; \ SHLIB_PATH=`pwd`:${SHLIB_PATH}; export SHLIB_PATH; \ - TCL_LIBRARY=${TOP_DIR}/library; export TCL_LIBRARY; \ - ( echo cd $(TOP_DIR)/tests\; source all ) | ./tcltest + TCL_LIBRARY="${TCL_BUILDTIME_LIBRARY}"; export TCL_LIBRARY; \ + ./tcltest $(TOP_DIR)/tests/all.tcl # Useful target to launch a built tcltest with the proper path,... runtest: tcltest LD_LIBRARY_PATH=`pwd`:${LD_LIBRARY_PATH}; export LD_LIBRARY_PATH; \ SHLIB_PATH=`pwd`:${SHLIB_PATH}; export SHLIB_PATH; \ - TCL_LIBRARY=${TOP_DIR}/library; export TCL_LIBRARY; \ + TCL_LIBRARY="${TCL_BUILDTIME_LIBRARY}"; export TCL_LIBRARY; \ ./tcltest # The following target outputs the name of the top-level source directory @@ -448,7 +468,7 @@ topDirName: gendate: yacc -l $(GENERIC_DIR)/tclGetDate.y sed -e 's/yy/TclDate/g' -e '/^#include <values.h>/d' \ - -e 's/SCCSID/RCS: @(#) \$Id\$' + -e "s/SCCSID/RCS: @(#) \$Id\$" -e '/#ifdef __STDC__/,/#endif/d' -e '/TclDateerrlab:/d' \ -e '/TclDatenewstate:/d' -e '/#pragma/d' \ <y.tab.c >$(GENERIC_DIR)/tclDate.c @@ -479,7 +499,7 @@ install: install-binaries install-libraries install-man # possible (e.g. if installing as root). install-binaries: $(TCL_LIB_FILE) $(TCL_STUB_LIB_FILE) $(TCL_BUILD_EXP_FILE) \ - tclsh + tclsh @for i in $(LIB_INSTALL_DIR) $(BIN_INSTALL_DIR) ; \ do \ if [ ! -d $$i ] ; then \ @@ -519,7 +539,7 @@ install-libraries: else true; \ fi; \ done; - @for i in http2.0 http1.0 opt0.1; \ + @for i in http2.0 http1.0 opt0.4 encoding msgcat1.0; \ do \ if [ ! -d $(SCRIPT_INSTALL_DIR)/$$i ] ; then \ echo "Making directory $(SCRIPT_INSTALL_DIR)/$$i"; \ @@ -538,7 +558,7 @@ install-libraries: echo "Installing $$i"; \ $(INSTALL_DATA) $$i $(SCRIPT_INSTALL_DIR); \ done; - @for i in http2.0 http1.0 opt0.1; \ + @for i in http2.0 http1.0 opt0.4 msgcat1.0; \ do \ for j in $(TOP_DIR)/library/$$i/*.tcl ; \ do \ @@ -546,6 +566,10 @@ install-libraries: $(INSTALL_DATA) $$j $(SCRIPT_INSTALL_DIR)/$$i; \ done; \ done; + @for i in $(TOP_DIR)/library/encoding/*.enc ; do \ + echo "Installing $$i"; \ + $(INSTALL_DATA) $$i $(SCRIPT_INSTALL_DIR)/encoding; \ + done; install-man: @for i in $(MAN_INSTALL_DIR) $(MAN1_INSTALL_DIR) $(MAN3_INSTALL_DIR) $(MANN_INSTALL_DIR) ; \ @@ -614,7 +638,9 @@ tclTestInit.o: $(UNIX_DIR)/tclAppInit.c rm -f tclAppInit.sav; \ mv tclAppInit.o tclAppInit.sav; \ fi; - $(CC) -c $(CC_SWITCHES) -DTCL_TEST $(UNIX_DIR)/tclAppInit.c + $(CC) -c $(CC_SWITCHES) \ + -DTCL_BUILDTIME_LIBRARY="\"${TCL_BUILDTIME_LIBRARY}\"" \ + -DTCL_TEST $(UNIX_DIR)/tclAppInit.c rm -f tclTestInit.o mv tclAppInit.o tclTestInit.o @if test -f tclAppInit.sav ; then \ @@ -636,17 +662,30 @@ xtTestInit.o: $(UNIX_DIR)/tclAppInit.c # Object files used on all Unix systems: -regexp.o: $(GENERIC_DIR)/regexp.c - $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/regexp.c +REGHDRS=$(GENERIC_DIR)/regex.h $(GENERIC_DIR)/regguts.h \ + $(GENERIC_DIR)/regcustom.h +regcomp.o: $(REGHDRS) $(GENERIC_DIR)/regcomp.c $(GENERIC_DIR)/regc_lex.c \ + $(GENERIC_DIR)/regc_color.c $(GENERIC_DIR)/regc_locale.c \ + $(GENERIC_DIR)/regc_nfa.c $(GENERIC_DIR)/regc_cvec.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/regcomp.c + +regexec.o: $(REGHDRS) $(GENERIC_DIR)/regexec.c $(GENERIC_DIR)/rege_dfa.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/regexec.c + +regfree.o: $(REGHDRS) $(GENERIC_DIR)/regfree.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/regfree.c + +regerror.o: $(REGHDRS) $(GENERIC_DIR)/regerrs.h $(GENERIC_DIR)/regerror.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/regerror.c tclAppInit.o: $(UNIX_DIR)/tclAppInit.c $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclAppInit.c # On unix we want to use the normal malloc/free implementation, so we -# specifically set the USE_TCL_ALLOC flag. +# specifically set the USE_TCLALLOC flag. tclAlloc.o: $(GENERIC_DIR)/tclAlloc.c - $(CC) -c $(CC_SWITCHES) -DUSE_TCL_ALLOC=0 $(GENERIC_DIR)/tclAlloc.c + $(CC) -c $(CC_SWITCHES) -DUSE_TCLALLOC=0 $(GENERIC_DIR)/tclAlloc.c tclAsync.o: $(GENERIC_DIR)/tclAsync.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclAsync.c @@ -675,12 +714,18 @@ tclCmdMZ.o: $(GENERIC_DIR)/tclCmdMZ.c tclDate.o: $(GENERIC_DIR)/tclDate.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclDate.c +tclCompCmds.o: $(GENERIC_DIR)/tclCompCmds.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclCompCmds.c + tclCompExpr.o: $(GENERIC_DIR)/tclCompExpr.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclCompExpr.c tclCompile.o: $(GENERIC_DIR)/tclCompile.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclCompile.c +tclEncoding.o: $(GENERIC_DIR)/tclEncoding.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclEncoding.c + tclEnv.o: $(GENERIC_DIR)/tclEnv.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclEnv.c @@ -729,6 +774,9 @@ tclLink.o: $(GENERIC_DIR)/tclLink.c tclListObj.o: $(GENERIC_DIR)/tclListObj.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclListObj.c +tclLiteral.o: $(GENERIC_DIR)/tclLiteral.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclLiteral.c + tclObj.o: $(GENERIC_DIR)/tclObj.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclObj.c @@ -774,6 +822,9 @@ tclNotify.o: $(GENERIC_DIR)/tclNotify.c tclParse.o: $(GENERIC_DIR)/tclParse.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclParse.c +tclParseExpr.o: $(GENERIC_DIR)/tclParseExpr.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclParseExpr.c + tclPanic.o: $(GENERIC_DIR)/tclPanic.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclPanic.c @@ -792,9 +843,18 @@ tclPreserve.o: $(GENERIC_DIR)/tclPreserve.c tclProc.o: $(GENERIC_DIR)/tclProc.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclProc.c +tclRegexp.o: $(GENERIC_DIR)/tclRegexp.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclRegexp.c + tclResolve.o: $(GENERIC_DIR)/tclResolve.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclResolve.c +tclResult.o: $(GENERIC_DIR)/tclResult.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclResult.c + +tclScan.o: $(GENERIC_DIR)/tclScan.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclScan.c + tclStringObj.o: $(GENERIC_DIR)/tclStringObj.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclStringObj.c @@ -804,6 +864,9 @@ tclStubInit.o: $(GENERIC_DIR)/tclStubInit.c tclUtil.o: $(GENERIC_DIR)/tclUtil.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclUtil.c +tclUtf.o: $(GENERIC_DIR)/tclUtf.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclUtf.c + tclVar.o: $(GENERIC_DIR)/tclVar.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclVar.c @@ -819,6 +882,12 @@ tclTestProcBodyObj.o: $(GENERIC_DIR)/tclTestProcBodyObj.c tclTimer.o: $(GENERIC_DIR)/tclTimer.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclTimer.c +tclThread.o: $(GENERIC_DIR)/tclThread.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclThread.c + +tclThreadTest.o: $(GENERIC_DIR)/tclThreadTest.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclThreadTest.c + tclUnixChan.o: $(UNIX_DIR)/tclUnixChan.c $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclUnixChan.c @@ -843,10 +912,13 @@ tclUnixSock.o: $(UNIX_DIR)/tclUnixSock.c tclUnixTest.o: $(UNIX_DIR)/tclUnixTest.c $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclUnixTest.c +tclUnixThrd.o: $(UNIX_DIR)/tclUnixThrd.c + $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclUnixThrd.c + tclUnixTime.o: $(UNIX_DIR)/tclUnixTime.c $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclUnixTime.c -tclUnixInit.o: $(UNIX_DIR)/tclUnixInit.c tclConfig.sh +tclUnixInit.o: $(UNIX_DIR)/tclUnixInit.c $(GENERIC_DIR)/tclInitScript.h tclConfig.sh $(CC) -c $(CC_SWITCHES) -DTCL_LIBRARY=\"${TCL_LIBRARY}\" \ -DTCL_PACKAGE_PATH="\"${TCL_PACKAGE_PATH}\"" \ $(UNIX_DIR)/tclUnixInit.c @@ -865,6 +937,9 @@ getcwd.o: $(COMPAT_DIR)/getcwd.c opendir.o: $(COMPAT_DIR)/opendir.c $(CC) -c $(STUB_CC_SWITCHES) $(COMPAT_DIR)/opendir.c +memcmp.o: $(COMPAT_DIR)/memcmp.c + $(CC) -c $(STUB_CC_SWITCHES) $(COMPAT_DIR)/memcmp.c + strncasecmp.o: $(COMPAT_DIR)/strncasecmp.c $(CC) -c $(STUB_CC_SWITCHES) $(COMPAT_DIR)/strncasecmp.c @@ -886,25 +961,13 @@ tmpnam.o: $(COMPAT_DIR)/tmpnam.c waitpid.o: $(COMPAT_DIR)/waitpid.c $(CC) -c $(STUB_CC_SWITCHES) $(COMPAT_DIR)/waitpid.c - # Stub library binaries, these must be compiled for use in a shared library # even though they will be placed in a static archive -tclIntPlatStubs.o: $(GENERIC_DIR)/tclIntPlatStubs.c - $(CC) -c $(STUB_CC_SWITCHES) $(GENERIC_DIR)/tclIntPlatStubs.c - -tclIntStubs.o: $(GENERIC_DIR)/tclIntStubs.c - $(CC) -c $(STUB_CC_SWITCHES) $(GENERIC_DIR)/tclIntStubs.c - -tclPlatStubs.o: $(GENERIC_DIR)/tclPlatStubs.c - $(CC) -c $(STUB_CC_SWITCHES) $(GENERIC_DIR)/tclPlatStubs.c tclStubLib.o: $(GENERIC_DIR)/tclStubLib.c $(CC) -c $(STUB_CC_SWITCHES) $(GENERIC_DIR)/tclStubLib.c -tclStubs.o: $(GENERIC_DIR)/tclStubs.c - $(CC) -c $(STUB_CC_SWITCHES) $(GENERIC_DIR)/tclStubs.c - .c.o: $(CC) -c $(CC_SWITCHES) $< @@ -954,7 +1017,7 @@ checkexports: $(TCL_LIB_FILE) # to put the distribution. # -DISTROOT = /tmp/dist +DISTROOT = /tmp/dist DISTNAME = tcl@TCL_VERSION@@TCL_PATCH_LEVEL@ ZIPNAME = tcl@TCL_MAJOR_VERSION@@TCL_MINOR_VERSION@@TCL_PATCH_LEVEL@.zip DISTDIR = $(DISTROOT)/$(DISTNAME) @@ -981,6 +1044,7 @@ dist: $(UNIX_DIR)/configure chmod +x $(DISTDIR)/unix/mkLinks mkdir $(DISTDIR)/generic cp -p $(GENERIC_DIR)/*.c $(GENERIC_DIR)/*.h $(DISTDIR)/generic + cp -p $(GENERIC_DIR)/*.decls $(DISTDIR)/generic cp -p $(GENERIC_DIR)/README $(DISTDIR)/generic cp -p $(GENERIC_DIR)/tclGetDate.y $(DISTDIR)/generic cp -p $(TOP_DIR)/changes $(TOP_DIR)/README* $(TOP_DIR)/license.terms \ @@ -988,11 +1052,13 @@ dist: $(UNIX_DIR)/configure mkdir $(DISTDIR)/library cp -p $(TOP_DIR)/license.terms $(TOP_DIR)/library/*.tcl \ $(TOP_DIR)/library/tclIndex $(DISTDIR)/library - for i in http2.0 http1.0 opt0.1; \ + for i in http2.0 http1.0 opt0.4 msgcat1.0; \ do \ mkdir $(DISTDIR)/library/$$i ;\ cp -p $(TOP_DIR)/library/$$i/*.tcl $(DISTDIR)/library/$$i; \ done; + mkdir $(DISTDIR)/library/encoding + cp -p $(TOP_DIR)/library/encoding/*.enc $(DISTDIR)/library/encoding mkdir $(DISTDIR)/doc cp -p $(TOP_DIR)/license.terms $(TOP_DIR)/doc/*.[13n] \ $(TOP_DIR)/doc/man.macros $(DISTDIR)/doc @@ -1003,8 +1069,8 @@ dist: $(UNIX_DIR)/configure mkdir $(DISTDIR)/tests cp -p $(TOP_DIR)/license.terms $(DISTDIR)/tests cp -p $(TOP_DIR)/tests/*.test $(TOP_DIR)/tests/README \ - $(TOP_DIR)/tests/all $(TOP_DIR)/tests/*.tcl \ - $(TOP_DIR)/tests/defs $(DISTDIR)/tests + $(TOP_DIR)/tests/all.tcl $(TOP_DIR)/tests/*.tcl \ + $(TOP_DIR)/tests/defs.tcl $(DISTDIR)/tests mkdir $(DISTDIR)/tests/pkg cp -p $(TOP_DIR)/license.terms $(DISTDIR)/tests/pkg cp -p $(TOP_DIR)/tests/pkg/*.tcl $(DISTDIR)/tests/pkg @@ -1030,6 +1096,17 @@ dist: $(UNIX_DIR)/configure $(DISTDIR)/unix/dltest cp -p $(UNIX_DIR)/dltest/configure.in $(UNIX_DIR)/dltest/configure \ $(UNIX_DIR)/dltest/README $(DISTDIR)/unix/dltest + mkdir $(DISTDIR)/tools + cp -p $(TOP_DIR)/tools/Makefile.in \ + $(TOP_DIR)/tools/README \ + $(TOP_DIR)/tools/configure \ + $(TOP_DIR)/tools/configure.in \ + $(TOP_DIR)/tools/*.tcl \ + $(TOP_DIR)/tools/man2tcl.c \ + $(TOP_DIR)/tools/tcl.wse.in \ + $(TOP_DIR)/tools/*.bmp \ + $(TOP_DIR)/tools/tcl.hpj.in \ + $(DISTDIR)/tools # # The following target can only be used for non-patch releases. Use @@ -1042,7 +1119,7 @@ alldist: dist $(DISTROOT)/$(ZIPNAME) cd $(DISTROOT); tar cf $(DISTNAME).tar $(DISTNAME); \ gzip -9 -c $(DISTNAME).tar > $(DISTNAME).tar.gz; \ - compress $(DISTNAME).tar; zip -r8 $(ZIPNAME) $(DISTNAME) + compress $(DISTNAME).tar; zip -qr8 $(ZIPNAME) $(DISTNAME) # # The target below is similar to "alldist" except it works for patch @@ -1065,6 +1142,17 @@ allpatch: dist mv $(DISTROOT)/old $(DISTROOT)/tcl${VERSION} # +# This target creates the HTML folder for Tcl & Tk and places it +# in DISTDIR/html. It uses the tcl8.1-tk8.1-man-html.tcl tool from +# the Tcl group's tool workspace. It depends on the Tcl & Tk being +# in directories called tcl8.1 & tk8.1 up two directories from the +# TOOL_DIR. +# + +html: + tclsh $(TOOL_DIR)/tcl8.1-tk8.1-man-html.tcl --htmldir=$(DISTDIR)/html + +# # 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 @@ -1075,10 +1163,7 @@ macdist: dist machtml machtml: rm -f $(DISTDIR)/mac/tclMacProjects.sea.hqx - tclsh $(TOOL_DIR)/man2html.tcl $(DISTDIR)/tmp ../.. tcl$(VERSION) - mv $(DISTDIR)/tmp/tcl$(VERSION) $(DISTDIR)/html rm -rf $(DISTDIR)/doc - rm -rf $(DISTDIR)/tmp tclsh $(TOOL_DIR)/cvtEOL.tcl $(DISTDIR) # diff --git a/unix/README b/unix/README index 5d30ab9..77e931e 100644 --- a/unix/README +++ b/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. -RCS: @(#) $Id: README,v 1.3 1999/02/09 03:31:55 stanton Exp $ +RCS: @(#) $Id: README,v 1.4 1999/04/16 00:48:03 stanton Exp $ How To Compile And Install Tcl: ------------------------------- @@ -37,6 +37,8 @@ How To Compile And Install Tcl: Makefile to use gcc after configure is run; if you do this, then information related to dynamic linking will be incorrect. + --enable-threads If this switch is set, Tcl will compile + itself with multithreading support. --disable-load If this switch is specified then Tcl will configure itself not to allow dynamic loading, even if your system appears to support it. @@ -75,15 +77,19 @@ 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 "tclsh8.0" or "libtcl8.0.so"; + version number in their names, such as "tclsh8.1" or "libtcl8.1.so"; to use the installed versions, either specify the version number - or create a symbolic link (e.g. from "tclsh" to "tclsh8.0"). + or create a symbolic link (e.g. from "tclsh" to "tclsh8.1"). -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. We're also interested -in hearing how to change the configuration setup so that Tcl compiles out -of the box on more platforms. +If you have trouble compiling Tcl, check out the following Web URL: + http://www.scriptics.com/software/install.html#Database +This is an on-line database of porting information. We make no +guarantees that this information is accurate, complete, or up-to-date, +but you may find it useful. If you get Tcl running on a new +configuration, we would be happy to receive new information to add to +the database. We're also interested in hearing how to change the +configuration setup so that Tcl compiles out of the box on more +platforms. Test suite ---------- diff --git a/unix/configure.in b/unix/configure.in index c8f25a4..1e339a4 100644 --- a/unix/configure.in +++ b/unix/configure.in @@ -2,12 +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) -# RCS: @(#) $Id: configure.in,v 1.30 1999/03/25 22:47:54 welch Exp $ +# RCS: @(#) $Id: configure.in,v 1.31 1999/04/16 00:48:03 stanton Exp $ -TCL_VERSION=8.0 +TCL_VERSION=8.1 TCL_MAJOR_VERSION=8 -TCL_MINOR_VERSION=0 -TCL_PATCH_LEVEL=".5" +TCL_MINOR_VERSION=1 +TCL_PATCH_LEVEL=b3 VERSION=${TCL_VERSION} if test "${prefix}" = "NONE"; then @@ -29,6 +29,25 @@ AC_SUBST(CC) fi AC_C_CROSS +# Threads support +AC_ARG_ENABLE(threads,[ --enable-threads enable Threads support],,enableval="no") + +if test "$enableval" = "yes"; then + AC_MSG_RESULT(Will compile with Threads support) + AC_DEFINE(TCL_THREADS) + AC_DEFINE(_REENTRANT) + + AC_CHECK_LIB(pthread,pthread_mutex_init,tcl_ok=yes,tcl_ok=no) + if test "$tcl_ok" = "yes"; then + # The space is needed + THREADS_LIBS=" -lpthread" + else + AC_MSG_WARN("Don t know how to find pthread lib on your system - you must disable thread support or edit the LIBS in the Makefile...") + fi +else + AC_MSG_RESULT(Will compile without Threads support (normal)) +fi + # set the warning flags depending on whether or not we are using gcc if test "${GCC}" = "yes" ; then CFLAGS_WARNING="-Wall -Wconversion" @@ -36,6 +55,19 @@ else CFLAGS_WARNING="" fi +#----------------------------- +# 64-bit support +#----------------------------- + +AC_ARG_ENABLE(64bit,[ --enable-64bit enable 64bit support],,enableval="no") + +if test "$enableval" = "yes"; then + AC_MSG_RESULT(Will compile with 64bit support) + do64bit=yes +else + do64bit=no +fi + #------------------------------------------------------------------------------ # If we're using GCC, see if the compiler understands -pipe. If so, use it. # It makes compiling go faster. (This is only a performance feature.) @@ -70,6 +102,7 @@ AC_CHECK_FUNC(strerror, , AC_DEFINE(NO_STRERROR)) AC_CHECK_FUNC(getwd, , AC_DEFINE(NO_GETWD)) AC_CHECK_FUNC(wait3, , AC_DEFINE(NO_WAIT3)) AC_CHECK_FUNC(uname, , AC_DEFINE(NO_UNAME)) +AC_CHECK_FUNC(realpath, , AC_DEFINE(NO_REALPATH)) #-------------------------------------------------------------------- # On a few very rare systems, all of the libm.a stuff is @@ -144,12 +177,16 @@ fi AC_CHECK_HEADER(string.h, tcl_ok=1, tcl_ok=0) AC_EGREP_HEADER(strstr, string.h, , tcl_ok=0) AC_EGREP_HEADER(strerror, string.h, , tcl_ok=0) +# See also memmove check below for a place where NO_STRING_H can be +# set and why. if test $tcl_ok = 0; then AC_DEFINE(NO_STRING_H) fi AC_CHECK_HEADER(sys/wait.h, , AC_DEFINE(NO_SYS_WAIT_H)) AC_CHECK_HEADER(dlfcn.h, , AC_DEFINE(NO_DLFCN_H)) -AC_HAVE_HEADERS(unistd.h) + +# OS/390 lacks sys/param.h (and doesn't need it, by chance). +AC_HAVE_HEADERS(unistd.h sys/param.h) #--------------------------------------------------------------------------- # Determine which interface to use to talk to the serial port. @@ -294,9 +331,23 @@ fi #-------------------------------------------------------------------- # Some systems (e.g., IRIX 4.0.5) lack the st_blksize field -# in struct stat. +# in struct stat. But we might be able to use fstatfs instead. #-------------------------------------------------------------------- AC_STRUCT_ST_BLKSIZE +AC_CHECK_FUNC(fstatfs, , AC_DEFINE(NO_FSTATFS)) + +#-------------------------------------------------------------------- +# Some system have no memcmp or it does not work with 8 bit +# data, this checks it and add memcmp.o to LIBOBJS if needed +#-------------------------------------------------------------------- +AC_FUNC_MEMCMP + +#-------------------------------------------------------------------- +# Some system like SunOS 4 and other BSD like systems +# have no memmove (we assume they have bcopy instead). +# {The replacement define is in compat/string.h} +#-------------------------------------------------------------------- +AC_CHECK_FUNC(memmove, , AC_DEFINE(NO_MEMMOVE) AC_DEFINE(NO_STRING_H)) #-------------------------------------------------------------------- # On some systems strstr is broken: it returns a pointer even @@ -592,6 +643,10 @@ if test "$tcl_checkBoth" = 1; then fi AC_CHECK_FUNC(gethostbyname, , AC_CHECK_LIB(nsl, main, [LIBS="$LIBS -lnsl"])) +# Add the threads support libraries + +LIBS="$LIBS$THREADS_LIBS" + #-------------------------------------------------------------------- # The statements below define a collection of symbols related to # dynamic loading and shared libraries: @@ -687,6 +742,7 @@ AC_CHECK_LIB(dl, dlopen, have_dl=yes, have_dl=no) # Step 3: set configuration options based on system name and version. +do64bit_ok=no fullSrcDir=`cd $srcdir; pwd` EXTRA_CFLAGS="" TCL_EXPORT_FILE_SUFFIX="" @@ -714,7 +770,7 @@ case $system in ;; AIX-*) SHLIB_CFLAGS="" - SHLIB_LD="$fullSrcDir/ldAix /bin/ld -bhalt:4 -bM:SRE -bE:lib.exp -H512 -T512 -bnoentry" + 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 tclLoadAix.o" @@ -724,7 +780,7 @@ case $system in TCL_NEEDS_EXP_FILE=1 TCL_EXPORT_FILE_SUFFIX='${VERSION}\$\{DBGX\}.exp' ;; - BSD/OS-2.1*|BSD/OS-3*|BSD/OS-4*) + BSD/OS-2.1*|BSD/OS-3*) SHLIB_CFLAGS="" SHLIB_LD="shlicc -r" SHLIB_LD_LIBS='${LIBS}' @@ -734,6 +790,16 @@ case $system in LD_FLAGS="" LD_SEARCH_FLAGS="" ;; + BSD/OS-4.*) + SHLIB_CFLAGS="-export-dynamic -fPIC" + SHLIB_LD="cc -shared" + SHLIB_LD_LIBS='${LIBS}' + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadDl.o" + DL_LIBS="-ldl" + LD_FLAGS="-export-dynamic" + LD_SEARCH_FLAGS="" + ;; dgux*) SHLIB_CFLAGS="-K PIC" SHLIB_LD="cc -G" @@ -771,7 +837,7 @@ case $system in IRIX-5.*|IRIX-6.*|IRIX64-6.5*) SHLIB_CFLAGS="" SHLIB_LD="ld -n32 -shared -rdata_shared" - SHLIB_LD_LIBS='${LIBS}' + SHLIB_LD_LIBS="" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" @@ -804,7 +870,7 @@ case $system in ;; Linux*) SHLIB_CFLAGS="-fPIC" - SHLIB_LD_LIBS='${LIBS}' + SHLIB_LD_LIBS="${LIBS}" SHLIB_SUFFIX=".so" if test "$have_dl" = yes; then SHLIB_LD="${CC} -shared" @@ -966,7 +1032,8 @@ case $system in TCL_UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.a' TCL_LIB_VERSIONS_OK=nodots ;; - SunOS-5*) + SunOS-5.[[0-6]]*) +# SunOS-5*) SHLIB_CFLAGS="-KPIC" SHLIB_LD="/usr/ccs/bin/ld -G -z text" @@ -980,6 +1047,40 @@ case $system in LD_FLAGS="" LD_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}' ;; + SunOS-5*) + SHLIB_CFLAGS="-KPIC" + SHLIB_LD="/usr/ccs/bin/ld -G -z text" + LD_FLAGS="" + + do64bit_ok=no + if test "$do64bit" = "yes" ; then + arch=`isainfo` + if test "$arch" = "sparcv9 sparc" ; then + if test "$CC" != "gcc" -a `$CC -v 2>&1 | grep -c gcc` = "0" ; then + do64bit_ok=yes + EXTRA_CFLAGS="-xarch=v9" + LD_FLAGS="-xarch=v9" + else + AC_MSG_WARN("64bit mode not supported using GCC on $system") + fi + else + AC_MSG_WARN("64bit mode only supported sparcv9 system") + fi + fi + + # Note: need the LIBS below, otherwise Tk won't find Tcl's + # symbols when dynamically loaded into tclsh. + + SHLIB_LD_LIBS='${LIBS}' + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadDl.o" + DL_LIBS="-ldl" + if test "$CC" = "gcc" -o `$CC -v 2>&1 | grep -c gcc` != "0" ; then + LD_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}' + else + LD_SEARCH_FLAGS='-R ${LIB_RUNTIME_DIR}' + fi + ;; ULTRIX-4.*) SHLIB_CFLAGS="-G 0" SHLIB_SUFFIX=".a" @@ -1014,6 +1115,10 @@ case $system in ;; esac +if test "$do64bit" = "yes" -a "$do64bit_ok" = "no" ; then + AC_MSG_WARN("64bit support being disabled -- not supported on this platform") +fi + # Step 4: If pseudo-static linking is in use (see K. B. Kenny, "Dynamic # Loading for Tcl -- What Became of It?". Proc. 2nd Tcl/Tk Workshop, # New Orleans, LA, Computerized Processes Unlimited, 1994), then we need @@ -1140,15 +1245,15 @@ if test "$DL_OBJS" != "tclLoadNone.o" ; then fi fi -# Set the default compiler switches based on the --enable-symbols option +# Set the default compiler switches based on the --enable-symbols option AC_ARG_ENABLE(symbols, [ --enable-symbols build with debugging symbols], [tcl_ok=$enableval], [tcl_ok=no]) if test "$tcl_ok" = "yes"; then - CFLAGS_DEFAULT=CFLAGS_DEBUG + CFLAGS='$(CFLAGS_DEBUG)' TCL_DBGX=g else - CFLAGS_DEFAULT=CFLAGS_OPTIMIZE + CFLAGS='$(CFLAGS_OPTIMIZE)' TCL_DBGX="" fi @@ -1216,8 +1321,8 @@ if test "$TCL_UNSHARED_LIB_SUFFIX" = "" ; then TCL_UNSHARED_LIB_SUFFIX='${VERSION}\$\{DBGX\}.a' fi AC_ARG_ENABLE(shared, - [ --enable-shared build libtcl as a shared library], - [tcl_ok=$enableval], [tcl_ok=no]) + [ --enable-shared build libtcl as a shared library (on by default)], + [tcl_ok=$enableval], [tcl_ok=yes]) if test "$tcl_ok" = "yes" -a "${SHLIB_SUFFIX}" != "" ; then TCL_SHARED_BUILD=1 TCL_SHLIB_CFLAGS="${SHLIB_CFLAGS}" @@ -1278,7 +1383,6 @@ else TCL_BUILD_LIB_SPEC="-bI:`pwd`/${TCL_BUILD_EXP_FILE}" TCL_LIB_SPEC="-bI:${exec_prefix}/lib/${TCL_EXP_FILE}" fi - VERSION='${VERSION}' eval "CFG_TCL_SHARED_LIB_SUFFIX=${TCL_SHARED_LIB_SUFFIX}" eval "CFG_TCL_UNSHARED_LIB_SUFFIX=${TCL_UNSHARED_LIB_SUFFIX}" @@ -1333,8 +1437,8 @@ AC_SUBST(TCL_STUB_LIB_PATH) AC_SUBST(MAKE_STUB_LIB) AC_SUBST(BUILD_DLTEST) +AC_SUBST(CFLAGS) AC_SUBST(CFLAGS_DEBUG) -AC_SUBST(CFLAGS_DEFAULT) AC_SUBST(CFLAGS_OPTIMIZE) AC_SUBST(CFLAGS_WARNING) AC_SUBST(CFG_TCL_SHARED_LIB_SUFFIX) diff --git a/unix/dltest/Makefile.in b/unix/dltest/Makefile.in index 1c0ab0f..96b7cc0 100644 --- a/unix/dltest/Makefile.in +++ b/unix/dltest/Makefile.in @@ -1,10 +1,11 @@ # This Makefile is used to create several test cases for Tcl's load # command. It also illustrates how to take advantage of configuration # exported by Tcl to set up Makefiles for shared libraries. -# RCS: @(#) $Id: Makefile.in,v 1.4 1999/03/11 21:47:39 stanton Exp $ +# RCS: @(#) $Id: Makefile.in,v 1.5 1999/04/16 00:48:06 stanton Exp $ +TCL_DBGX = @TCL_DBGX@ CC = @CC@ -LIBS = @TCL_BUILD_STUB_LIB_SPEC@ @SHLIB_LD_LIBS@ +LIBS = @TCL_BUILD_STUB_LIB_SPEC@ @TCL_LIBS@ AC_FLAGS = @EXTRA_CFLAGS@ SHLIB_CFLAGS = @SHLIB_CFLAGS@ SHLIB_LD = @SHLIB_LD@ diff --git a/unix/dltest/configure.in b/unix/dltest/configure.in index a65ac38..bd7b904 100644 --- a/unix/dltest/configure.in +++ b/unix/dltest/configure.in @@ -2,7 +2,7 @@ dnl This file is an input file used by the GNU "autoconf" program to dnl generate the file "configure", which is run to configure the dnl Makefile in this directory. AC_INIT(pkga.c) -# RCS: @(#) $Id: configure.in,v 1.4 1999/03/11 21:47:39 stanton Exp $ +# RCS: @(#) $Id: configure.in,v 1.5 1999/04/16 00:48:06 stanton Exp $ # Recover information that Tcl computed with its configure script. @@ -27,5 +27,7 @@ TCL_LIBS=$TCL_LIBS AC_SUBST(TCL_LIBS) TCL_VERSION=$TCL_VERSION AC_SUBST(TCL_VERSION) +TCL_DBGX=$TCL_DBGX +AC_SUBST(TCL_DBGX) AC_OUTPUT(Makefile) diff --git a/unix/dltest/pkge.c b/unix/dltest/pkge.c index 16acf56..6c74366 100644 --- a/unix/dltest/pkge.c +++ b/unix/dltest/pkge.c @@ -10,8 +10,9 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: pkge.c,v 1.3 1999/03/11 21:47:40 stanton Exp $ + * RCS: @(#) $Id: pkge.c,v 1.4 1999/04/16 00:48:06 stanton Exp $ */ + #include "tcl.h" /* @@ -45,8 +46,9 @@ Pkge_Init(interp) Tcl_Interp *interp; /* Interpreter in which the package is * to be made available. */ { + static char script[] = "if 44 {open non_existent}"; if (Tcl_InitStubs(interp, TCL_VERSION, 1) == NULL) { return TCL_ERROR; } - return Tcl_Eval(interp, "if 44 {open non_existent}"); + return Tcl_Eval(interp, script); } diff --git a/unix/dltest/pkgf.c b/unix/dltest/pkgf.c index 7e988d4..fc7a936 100644 --- a/unix/dltest/pkgf.c +++ b/unix/dltest/pkgf.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. * - * RCS: @(#) $Id: pkgf.c,v 1.3 1999/03/11 21:47:40 stanton Exp $ + * RCS: @(#) $Id: pkgf.c,v 1.4 1999/04/16 00:48:06 stanton Exp $ */ #include "tcl.h" @@ -45,8 +45,9 @@ Pkgf_Init(interp) Tcl_Interp *interp; /* Interpreter in which the package is * to be made available. */ { + static char script[] = "if 44 {open non_existent}"; if (Tcl_InitStubs(interp, TCL_VERSION, 1) == NULL) { return TCL_ERROR; } - return Tcl_Eval(interp, "if 44 {open non_existent}"); + return Tcl_Eval(interp, script); } diff --git a/unix/mkLinks b/unix/mkLinks index f039c17..0a07ade 100644 --- a/unix/mkLinks +++ b/unix/mkLinks @@ -36,12 +36,8 @@ if test -r http.n; then 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 + rm -f Safe\.n + ln safe.n Safe\.n fi if test -r AddErrInfo.3; then rm -f Tcl_AddErrorInfo.3 @@ -71,6 +67,10 @@ if test -r SetResult.3; then rm -f Tcl_AppendElement.3 ln SetResult.3 Tcl_AppendElement.3 fi +if test -r StringObj.3; then + rm -f Tcl_AppendObjToObj.3 + ln StringObj.3 Tcl_AppendObjToObj.3 +fi if test -r SetResult.3; then rm -f Tcl_AppendResult.3 ln SetResult.3 Tcl_AppendResult.3 @@ -131,6 +131,18 @@ if test -r Concat.3; then rm -f Tcl_Concat.3 ln Concat.3 Tcl_Concat.3 fi +if test -r StringObj.3; then + rm -f Tcl_ConcatObj.3 + ln StringObj.3 Tcl_ConcatObj.3 +fi +if test -r Thread.3; then + rm -f Tcl_ConditionNotify.3 + ln Thread.3 Tcl_ConditionNotify.3 +fi +if test -r Thread.3; then + rm -f Tcl_ConditionWait.3 + ln Thread.3 Tcl_ConditionWait.3 +fi if test -r SplitList.3; then rm -f Tcl_ConvertElement.3 ln SplitList.3 Tcl_ConvertElement.3 @@ -163,6 +175,10 @@ if test -r CrtCommand.3; then rm -f Tcl_CreateCommand.3 ln CrtCommand.3 Tcl_CreateCommand.3 fi +if test -r Encoding.3; then + rm -f Tcl_CreateEncoding.3 + ln Encoding.3 Tcl_CreateEncoding.3 +fi if test -r Notifier.3; then rm -f Tcl_CreateEventSource.3 ln Notifier.3 Tcl_CreateEventSource.3 @@ -195,6 +211,10 @@ if test -r CrtSlave.3; then rm -f Tcl_CreateSlave.3 ln CrtSlave.3 Tcl_CreateSlave.3 fi +if test -r Exit.3; then + rm -f Tcl_CreateThreadExitHandler.3 + ln Exit.3 Tcl_CreateThreadExitHandler.3 +fi if test -r CrtTimerHdlr.3; then rm -f Tcl_CreateTimerHandler.3 ln CrtTimerHdlr.3 Tcl_CreateTimerHandler.3 @@ -303,6 +323,10 @@ if test -r CrtInterp.3; then rm -f Tcl_DeleteInterp.3 ln CrtInterp.3 Tcl_DeleteInterp.3 fi +if test -r Exit.3; then + rm -f Tcl_DeleteThreadExitHandler.3 + ln Exit.3 Tcl_DeleteThreadExitHandler.3 +fi if test -r CrtTimerHdlr.3; then rm -f Tcl_DeleteTimerHandler.3 ln CrtTimerHdlr.3 Tcl_DeleteTimerHandler.3 @@ -315,6 +339,10 @@ if test -r DetachPids.3; then rm -f Tcl_DetachPids.3 ln DetachPids.3 Tcl_DetachPids.3 fi +if test -r SaveResult.3; then + rm -f Tcl_DiscardResult.3 + ln SaveResult.3 Tcl_DiscardResult.3 +fi if test -r DoOneEvent.3; then rm -f Tcl_DoOneEvent.3 ln DoOneEvent.3 Tcl_DoOneEvent.3 @@ -340,12 +368,24 @@ if test -r Eval.3; then ln Eval.3 Tcl_Eval.3 fi if test -r Eval.3; then + rm -f Tcl_Eval2.3 + ln Eval.3 Tcl_Eval2.3 +fi +if test -r Eval.3; then rm -f Tcl_EvalFile.3 ln Eval.3 Tcl_EvalFile.3 fi -if test -r EvalObj.3; then +if test -r Eval.3; then rm -f Tcl_EvalObj.3 - ln EvalObj.3 Tcl_EvalObj.3 + ln Eval.3 Tcl_EvalObj.3 +fi +if test -r Eval.3; then + rm -f Tcl_EvalObjv.3 + ln Eval.3 Tcl_EvalObjv.3 +fi +if test -r ParseCmd.3; then + rm -f Tcl_EvalTokens.3 + ln ParseCmd.3 Tcl_EvalTokens.3 fi if test -r Preserve.3; then rm -f Tcl_EventuallyFree.3 @@ -391,10 +431,22 @@ if test -r ExprLong.3; then rm -f Tcl_ExprString.3 ln ExprLong.3 Tcl_ExprString.3 fi +if test -r Encoding.3; then + rm -f Tcl_ExternalToUtf.3 + ln Encoding.3 Tcl_ExternalToUtf.3 +fi +if test -r Encoding.3; then + rm -f Tcl_ExternalToUtfDString.3 + ln Encoding.3 Tcl_ExternalToUtfDString.3 +fi if test -r Exit.3; then rm -f Tcl_Finalize.3 ln Exit.3 Tcl_Finalize.3 fi +if test -r Exit.3; then + rm -f Tcl_FinalizeThread.3 + ln Exit.3 Tcl_FinalizeThread.3 +fi if test -r FindExec.3; then rm -f Tcl_FindExecutable.3 ln FindExec.3 Tcl_FindExecutable.3 @@ -415,6 +467,14 @@ if test -r Alloc.3; then rm -f Tcl_Free.3 ln Alloc.3 Tcl_Free.3 fi +if test -r Encoding.3; then + rm -f Tcl_FreeEncoding.3 + ln Encoding.3 Tcl_FreeEncoding.3 +fi +if test -r ParseCmd.3; then + rm -f Tcl_FreeParse.3 + ln ParseCmd.3 Tcl_FreeParse.3 +fi if test -r CrtSlave.3; then rm -f Tcl_GetAlias.3 ln CrtSlave.3 Tcl_GetAlias.3 @@ -435,6 +495,10 @@ if test -r BoolObj.3; then rm -f Tcl_GetBooleanFromObj.3 ln BoolObj.3 Tcl_GetBooleanFromObj.3 fi +if test -r ByteArrObj.3; then + rm -f Tcl_GetByteArrayFromObj.3 + ln ByteArrObj.3 Tcl_GetByteArrayFromObj.3 +fi if test -r OpenFileChnl.3; then rm -f Tcl_GetChannel.3 ln OpenFileChnl.3 Tcl_GetChannel.3 @@ -483,6 +547,18 @@ if test -r DoubleObj.3; then rm -f Tcl_GetDoubleFromObj.3 ln DoubleObj.3 Tcl_GetDoubleFromObj.3 fi +if test -r Encoding.3; then + rm -f Tcl_GetEncoding.3 + ln Encoding.3 Tcl_GetEncoding.3 +fi +if test -r Encoding.3; then + rm -f Tcl_GetEncodingName.3 + ln Encoding.3 Tcl_GetEncodingName.3 +fi +if test -r Encoding.3; then + rm -f Tcl_GetEncodingNames.3 + ln Encoding.3 Tcl_GetEncodingNames.3 +fi if test -r SetErrno.3; then rm -f Tcl_GetErrno.3 ln SetErrno.3 Tcl_GetErrno.3 @@ -548,6 +624,10 @@ if test -r GetStdChan.3; then ln GetStdChan.3 Tcl_GetStdChannel.3 fi if test -r StringObj.3; then + rm -f Tcl_GetString.3 + ln StringObj.3 Tcl_GetString.3 +fi +if test -r StringObj.3; then rm -f Tcl_GetStringFromObj.3 ln StringObj.3 Tcl_GetStringFromObj.3 fi @@ -555,6 +635,10 @@ if test -r SetResult.3; then rm -f Tcl_GetStringResult.3 ln SetResult.3 Tcl_GetStringResult.3 fi +if test -r Thread.3; then + rm -f Tcl_GetThreadData.3 + ln Thread.3 Tcl_GetThreadData.3 +fi if test -r SetVar.3; then rm -f Tcl_GetVar.3 ln SetVar.3 Tcl_GetVar.3 @@ -563,18 +647,22 @@ if test -r SetVar.3; then rm -f Tcl_GetVar2.3 ln SetVar.3 Tcl_GetVar2.3 fi +if test -r SetVar.3; then + rm -f Tcl_GetVar2Ex.3 + ln SetVar.3 Tcl_GetVar2Ex.3 +fi if test -r OpenFileChnl.3; then rm -f Tcl_Gets.3 ln OpenFileChnl.3 Tcl_Gets.3 fi +if test -r OpenFileChnl.3; then + rm -f Tcl_GetsObj.3 + ln OpenFileChnl.3 Tcl_GetsObj.3 +fi if test -r Eval.3; then rm -f Tcl_GlobalEval.3 ln Eval.3 Tcl_GlobalEval.3 fi -if test -r EvalObj.3; then - rm -f Tcl_GlobalEvalObj.3 - ln EvalObj.3 Tcl_GlobalEvalObj.3 -fi if test -r Hash.3; then rm -f Tcl_HashStats.3 ln Hash.3 Tcl_HashStats.3 @@ -663,10 +751,22 @@ if test -r SplitList.3; then rm -f Tcl_Merge.3 ln SplitList.3 Tcl_Merge.3 fi +if test -r Thread.3; then + rm -f Tcl_MutexLock.3 + ln Thread.3 Tcl_MutexLock.3 +fi +if test -r Thread.3; then + rm -f Tcl_MutexUnlock.3 + ln Thread.3 Tcl_MutexUnlock.3 +fi if test -r BoolObj.3; then rm -f Tcl_NewBooleanObj.3 ln BoolObj.3 Tcl_NewBooleanObj.3 fi +if test -r ByteArrObj.3; then + rm -f Tcl_NewByteArrayObj.3 + ln ByteArrObj.3 Tcl_NewByteArrayObj.3 +fi if test -r DoubleObj.3; then rm -f Tcl_NewDoubleObj.3 ln DoubleObj.3 Tcl_NewDoubleObj.3 @@ -699,13 +799,17 @@ if test -r CrtChannel.3; then rm -f Tcl_NotifyChannel.3 ln CrtChannel.3 Tcl_NotifyChannel.3 fi -if test -r ObjSetVar.3; then +if test -r Utf.3; then + rm -f Tcl_NumUtfChars.3 + ln Utf.3 Tcl_NumUtfChars.3 +fi +if test -r SetVar.3; then rm -f Tcl_ObjGetVar2.3 - ln ObjSetVar.3 Tcl_ObjGetVar2.3 + ln SetVar.3 Tcl_ObjGetVar2.3 fi -if test -r ObjSetVar.3; then +if test -r SetVar.3; then rm -f Tcl_ObjSetVar2.3 - ln ObjSetVar.3 Tcl_ObjSetVar2.3 + ln SetVar.3 Tcl_ObjSetVar2.3 fi if test -r OpenFileChnl.3; then rm -f Tcl_OpenCommandChannel.3 @@ -723,6 +827,26 @@ if test -r OpenTcp.3; then rm -f Tcl_OpenTcpServer.3 ln OpenTcp.3 Tcl_OpenTcpServer.3 fi +if test -r ParseCmd.3; then + rm -f Tcl_ParseBraces.3 + ln ParseCmd.3 Tcl_ParseBraces.3 +fi +if test -r ParseCmd.3; then + rm -f Tcl_ParseCommand.3 + ln ParseCmd.3 Tcl_ParseCommand.3 +fi +if test -r ParseCmd.3; then + rm -f Tcl_ParseExpr.3 + ln ParseCmd.3 Tcl_ParseExpr.3 +fi +if test -r ParseCmd.3; then + rm -f Tcl_ParseQuotedString.3 + ln ParseCmd.3 Tcl_ParseQuotedString.3 +fi +if test -r ParseCmd.3; then + rm -f Tcl_ParseVarName.3 + ln ParseCmd.3 Tcl_ParseVarName.3 +fi if test -r PkgRequire.3; then rm -f Tcl_PkgProvide.3 ln PkgRequire.3 Tcl_PkgProvide.3 @@ -732,10 +856,6 @@ if test -r PkgRequire.3; then ln PkgRequire.3 Tcl_PkgRequire.3 fi if test -r AddErrInfo.3; then - rm -f Tcl_SetErrorCodeVA.3 - ln AddErrInfo.3 Tcl_SetErrorCodeVA.3 -fi -if test -r AddErrInfo.3; then rm -f Tcl_PosixError.3 ln AddErrInfo.3 Tcl_PosixError.3 fi @@ -755,6 +875,10 @@ if test -r OpenFileChnl.3; then rm -f Tcl_Read.3 ln OpenFileChnl.3 Tcl_Read.3 fi +if test -r OpenFileChnl.3; then + rm -f Tcl_ReadChars.3 + ln OpenFileChnl.3 Tcl_ReadChars.3 +fi if test -r Alloc.3; then rm -f Tcl_Realloc.3 ln Alloc.3 Tcl_Realloc.3 @@ -803,6 +927,14 @@ if test -r SetResult.3; then rm -f Tcl_ResetResult.3 ln SetResult.3 Tcl_ResetResult.3 fi +if test -r SaveResult.3; then + rm -f Tcl_RestoreResult.3 + ln SaveResult.3 Tcl_RestoreResult.3 +fi +if test -r SaveResult.3; then + rm -f Tcl_SaveResult.3 + ln SaveResult.3 Tcl_SaveResult.3 +fi if test -r SplitList.3; then rm -f Tcl_ScanElement.3 ln SplitList.3 Tcl_ScanElement.3 @@ -827,6 +959,14 @@ if test -r BoolObj.3; then rm -f Tcl_SetBooleanObj.3 ln BoolObj.3 Tcl_SetBooleanObj.3 fi +if test -r ByteArrObj.3; then + rm -f Tcl_SetByteArrayLength.3 + ln ByteArrObj.3 Tcl_SetByteArrayLength.3 +fi +if test -r ByteArrObj.3; then + rm -f Tcl_SetByteArrayObj.3 + ln ByteArrObj.3 Tcl_SetByteArrayObj.3 +fi if test -r CrtChannel.3; then rm -f Tcl_SetChannelBufferSize.3 ln CrtChannel.3 Tcl_SetChannelBufferSize.3 @@ -852,6 +992,10 @@ if test -r SetErrno.3; then ln SetErrno.3 Tcl_SetErrno.3 fi if test -r AddErrInfo.3; then + rm -f Tcl_SetErrorCodeVA.3 + ln AddErrInfo.3 Tcl_SetErrorCodeVA.3 +fi +if test -r AddErrInfo.3; then rm -f Tcl_SetErrorCode.3 ln AddErrInfo.3 Tcl_SetErrorCode.3 fi @@ -903,6 +1047,10 @@ if test -r StringObj.3; then rm -f Tcl_SetStringObj.3 ln StringObj.3 Tcl_SetStringObj.3 fi +if test -r Encoding.3; then + rm -f Tcl_SetSystemEncoding.3 + ln Encoding.3 Tcl_SetSystemEncoding.3 +fi if test -r Notifier.3; then rm -f Tcl_SetTimer.3 ln Notifier.3 Tcl_SetTimer.3 @@ -915,6 +1063,10 @@ if test -r SetVar.3; then rm -f Tcl_SetVar2.3 ln SetVar.3 Tcl_SetVar2.3 fi +if test -r SetVar.3; then + rm -f Tcl_SetVar2Ex.3 + ln SetVar.3 Tcl_SetVar2Ex.3 +fi if test -r Sleep.3; then rm -f Tcl_Sleep.3 ln Sleep.3 Tcl_Sleep.3 @@ -951,6 +1103,30 @@ if test -r Translate.3; then rm -f Tcl_TranslateFileName.3 ln Translate.3 Tcl_TranslateFileName.3 fi +if test -r Utf.3; then + rm -f Tcl_UniChar.3 + ln Utf.3 Tcl_UniChar.3 +fi +if test -r Utf.3; then + rm -f Tcl_UniCharAtIndex.3 + ln Utf.3 Tcl_UniCharAtIndex.3 +fi +if test -r ToUpper.3; then + rm -f Tcl_UniCharToLower.3 + ln ToUpper.3 Tcl_UniCharToLower.3 +fi +if test -r ToUpper.3; then + rm -f Tcl_UniCharToTitle.3 + ln ToUpper.3 Tcl_UniCharToTitle.3 +fi +if test -r ToUpper.3; then + rm -f Tcl_UniCharToUpper.3 + ln ToUpper.3 Tcl_UniCharToUpper.3 +fi +if test -r Utf.3; then + rm -f Tcl_UniCharToUtf.3 + ln Utf.3 Tcl_UniCharToUtf.3 +fi if test -r LinkVar.3; then rm -f Tcl_UnlinkVar.3 ln LinkVar.3 Tcl_UnlinkVar.3 @@ -987,6 +1163,58 @@ if test -r LinkVar.3; then rm -f Tcl_UpdateLinkedVar.3 ln LinkVar.3 Tcl_UpdateLinkedVar.3 fi +if test -r Utf.3; then + rm -f Tcl_UtfAtIndex.3 + ln Utf.3 Tcl_UtfAtIndex.3 +fi +if test -r Utf.3; then + rm -f Tcl_UtfBackslash.3 + ln Utf.3 Tcl_UtfBackslash.3 +fi +if test -r Utf.3; then + rm -f Tcl_UtfCharComplete.3 + ln Utf.3 Tcl_UtfCharComplete.3 +fi +if test -r Utf.3; then + rm -f Tcl_UtfFindFirst.3 + ln Utf.3 Tcl_UtfFindFirst.3 +fi +if test -r Utf.3; then + rm -f Tcl_UtfFindLast.3 + ln Utf.3 Tcl_UtfFindLast.3 +fi +if test -r Utf.3; then + rm -f Tcl_UtfNext.3 + ln Utf.3 Tcl_UtfNext.3 +fi +if test -r Utf.3; then + rm -f Tcl_UtfPrev.3 + ln Utf.3 Tcl_UtfPrev.3 +fi +if test -r Encoding.3; then + rm -f Tcl_UtfToExternal.3 + ln Encoding.3 Tcl_UtfToExternal.3 +fi +if test -r Encoding.3; then + rm -f Tcl_UtfToExternalDString.3 + ln Encoding.3 Tcl_UtfToExternalDString.3 +fi +if test -r ToUpper.3; then + rm -f Tcl_UtfToLower.3 + ln ToUpper.3 Tcl_UtfToLower.3 +fi +if test -r ToUpper.3; then + rm -f Tcl_UtfToTitle.3 + ln ToUpper.3 Tcl_UtfToTitle.3 +fi +if test -r Utf.3; then + rm -f Tcl_UtfToUniChar.3 + ln Utf.3 Tcl_UtfToUniChar.3 +fi +if test -r ToUpper.3; then + rm -f Tcl_UtfToUpper.3 + ln ToUpper.3 Tcl_UtfToUpper.3 +fi if test -r Eval.3; then rm -f Tcl_VarEval.3 ln Eval.3 Tcl_VarEval.3 @@ -1007,6 +1235,14 @@ if test -r OpenFileChnl.3; then rm -f Tcl_Write.3 ln OpenFileChnl.3 Tcl_Write.3 fi +if test -r OpenFileChnl.3; then + rm -f Tcl_WriteChars.3 + ln OpenFileChnl.3 Tcl_WriteChars.3 +fi +if test -r OpenFileChnl.3; then + rm -f Tcl_WriteObj.3 + ln OpenFileChnl.3 Tcl_WriteObj.3 +fi if test -r WrongNumArgs.3; then rm -f Tcl_WrongNumArgs.3 ln WrongNumArgs.3 Tcl_WrongNumArgs.3 diff --git a/unix/porting.notes b/unix/porting.notes index f04e5ca..5376663 100644 --- a/unix/porting.notes +++ b/unix/porting.notes @@ -1,412 +1,11 @@ -This file contains a collection of notes that various people have -provided about porting Tcl to various machines and operating systems. -I don't have personal access to any of these machines, so I make -no guarantees that the notes are correct, complete, or up-to-date. -If you see the word "I" in any explanations, it refers to the person -who contributed the information, not to me; this means that I -probably can't answer any questions about any of this stuff. In -some cases, a person has volunteered to act as a contact point for -questions about porting Tcl to a particular machine; in these -cases the person's name and e-mail address are listed. I'm -interested in getting new porting information to add to the file; -please mail updates to "john.ousterhout@eng.sun.com". +RCS: @(#) $Id: porting.notes,v 1.3 1999/04/16 00:48:03 stanton Exp $ -This file reflects information provided for Tcl 7.4 and later releases (8.x). -If there is no information for your configuration in this file, check -the file "porting.old" too; it contains information that was -submitted for Tcl 7.3 and earlier releases, and some of that information -may still be valid. +This file used to contain a collection of notes that various people +had provided about porting Tcl to various machines and operating +systems. This information is now available in the Tcl porting +database at the following location: -A new porting database has recently become available on the Web at -the following URL: - http://www.sunlabs.com/cgi-bin/tcl/info.8.0 -This page provides information about the platforms on which Tcl and -and Tk 8.0 have been compiled and what changes were needed to get Tcl -and Tk to compile. You can also add new entries to that database -when you install Tcl and Tk on a new platform. The Web database is -likely to be more up-to-date than this file. - -sccsid = RCS: @(#) $Id: porting.notes,v 1.2 1998/09/14 18:40:16 stanton Exp $ - --------------------------------------------- -Solaris, various versions --------------------------------------------- - -1. If typing "make test" results in an error message saying that -there are no "*.test" files, or you get lots of globbing errors, -it's probably because your system doesn't have cc installed and -you used gcc. In order for this to work, you have to set your -CC environment variable to gcc and your CPP environment variable -to "gcc -E" before running the configure script. - -2. Make sure that /usr/ucb is not in your PATH or LD_LIBRARY_PATH -environment variables; this will cause confusion between the new -Solaris libraries and older UCB versions (Tcl will expect one version -and get another). - -3. There have been several reports of problems with the "glob" command. -So far these reports have all been for older versions of Tcl, but -if you run into problems, edit the Makefile after "configure" is -run and add "-DNO_DIRENT_H=1" to the definitions of DEFS. Do this -before compiling. - --------------------------------------------- -SunOS 4 and potentially other OSes --------------------------------------------- - -On systems where both getcwd(3) and getwd(3) exist, check the man -page and if getcwd, like on SunOS 4, uses popen to pwd(1) -add -DUSEGETWD to the flags CFLAGS so getwd will be used instead. - -That is, change the CFLAGS = -O line so it reads -CFLAGS = -O -DUSEGETWD - --------------------------------------------- -Linux, ELF, various versions/distributions --------------------------------------------- - -If ./configure --enable-shared complains it can not do a shared -library you might have to make the following symbolic link: -ln -s /lib/libdl.so.1 /lib/libdl.so -then remove config.cache and re run configure. - --------------------------------------------- -Pyramid DC/OSx SVr4, DC/OSx version 94c079 --------------------------------------------- - -Tcl seems to dump core in cmdinfo.test when compiled with the -optimiser turned on in TclEval which calls 'free'. To get around -this, turn the optimiser off. - --------------------------------------------- -SGI machines, IRIX 5.2, 5.3, IRIX64 6.0.1 --------------------------------------------- - -1. If you compile with gcc-2.6.3 under some versions of IRIX (e.g. - 4.0.5), DBL_MAX is defined too large for gcc and Tcl complains - about all floating-point values being too large to represent. - If this happens, redefining DBL_MAX to 9.99e299. - -2. Add "-D_BSD_TIME" to CFLAGS in Makefile. This avoids type conflicts -in the prototype for the gettimeofday procedure. - -2. If you're running under Irix 6.x and tclsh dumps core, try -removing -O from the CFLAGS in Makefile and recompiling; compiler -optimizations seem to cause problems on some machines. - --------------------------------------------- -IBM RTs, AOS --------------------------------------------- - -1. Steal fmod from 4.4BSD -2. Add a #define to tclExpr such that: -extern double fmod(); -is defined conditionally on ibm032 - --------------------------------------------- -QNX 4.22 --------------------------------------------- - -tclPort.h - - commented out 2 lines containing #include <sys/param.h> - -tcl.h - - changed #define VARARGS () - - to #ifndef __QNX__ - #define VARARGS () - #else - #define VARARGS (void *, ...) - #endif - --------------------------------------------- -Interactive UNIX --------------------------------------------- - -Add the switch -Xp to LIBS in Makefile; otherwise strftime will not -be found when linking. - --------------------------------------------- -Motorola SVR4 V4.2 (m88k) --------------------------------------------- - -For Motorola Unix R40V4.2 (m88k architechure), use /usr/ucb/cc instead of -/usr/bin/cc. Otherwise, the compile will fail because of conflicts over -the gettimeofday() call. - -Also, -DNO_DIRENT_H=1 is required for the "glob" command to work. - --------------------------------------------- -NeXTSTEP 3.x --------------------------------------------- - -Here's the set of changes I made to make 7.5b3 compile cleanly on -NeXTSTEP3.x. - -Here are a couple lines from unix/Makefile: - -# Added utsname.o, which implements a uname() emulation for NeXTSTEP. -COMPAT_OBJS = getcwd.o strtod.o tmpnam.o utsname.o - -TCL_NAMES=\ - -Dstrtod=tcl_strtod -Dtmpnam=tcl_tmpnam -Dgetcwd=tcl_getcwd \ - -Dpanic=tcl_panic -Dmatherr=tcl_matherr \ - -Duname=tcl_uname -Dutsname=tcl_utsname - -# Added mode_t, pid_t, and O_NONBLOCK definitions. -AC_FLAGS = -DNO_DIRENT_H=1 -DHAVE_UNISTD_H=1 -DHAVE_SYS_TIME_H=1 --DTIME_WITH_SYS_TIME=1 -DHAVE_TM_ZONE=1 -DHAVE_TM_GMTOFF=1 -DHAVE_TIMEZONE_VAR=1 --DSTDC_HEADERS=1 -Dmode_t=int -Dpid_t=int -DO_NONBLOCK=O_NDELAY ${TCL_NAMES} - - -Here are diffs for other files. utsname.[hc] are a couple files I added -to compat/ I'm not clear whether that's where they legitimately belong -- I considered stashing them in tclLoadNext.c instead. The tclIO.c -change was a bug, I believe, which I reported on comp.lang.tcl and -has apparently been noted and fixed. The objc_loadModules() change -allows "load" to load object code containing Objective-C code in -addition to plain C code. - ---- -scott hess <shess@winternet.com> (WWW to "http://www.winternet.com/~shess/") -Work: 12550 Portland Avenue South #121, Burnsville, MN 55337 (612)895-1208 - - -diff -rc tcl7.5b3.orig/compat/utsname.c tcl7.5b3/compat/utsname.c -*** tcl7.5b3.orig/compat/utsname.c Tue Apr 2 13:57:23 1996 ---- tcl7.5b3/compat/utsname.c Mon Mar 18 11:05:54 1996 -*************** -*** 0 **** ---- 1,27 ---- -+ /* -+ * utsname.c -- -+ * -+ * This file is an emulation of the POSIX uname() function -+ * under NeXTSTEP 3.x. -+ * -+ */ -+ - -+ #include "utsname.h" -+ #include <mach-o/arch.h> -+ #include <stdio.h> -+ - -+ int uname( struct utsname *name) -+ { -+ const NXArchInfo *arch; -+ if( gethostname( name->nodename, sizeof( name->nodename))==-1) { -+ return -1; -+ } -+ if( (arch=NXGetLocalArchInfo())==NULL) { -+ return -1; -+ } -+ strncpy( name->machine, arch->description, sizeof( name->machine)); -+ strcpy( name->sysname, "NEXTSTEP"); -+ strcpy( name->release, "0"); -+ strcpy( name->version, "3"); -+ return 0; -+ } -diff -rc tcl7.5b3.orig/compat/utsname.h tcl7.5b3/compat/utsname.h -*** tcl7.5b3.orig/compat/utsname.h Tue Apr 2 13:57:26 1996 ---- tcl7.5b3/compat/utsname.h Mon Mar 18 10:34:05 1996 -*************** -*** 0 **** ---- 1,22 ---- -+ /* -+ * utsname.h -- -+ * -+ * This file is an emulation of the POSIX uname() function -+ * under NeXTSTEP. -+ * -+ */ -+ - -+ #ifndef _UTSNAME -+ #define _UTSNAME -+ - -+ struct utsname { -+ char sysname[ 32]; -+ char nodename[ 32]; -+ char release[ 32]; -+ char version[ 32]; -+ char machine[ 32]; -+ }; -+ - -+ extern int uname( struct utsname *name); -+ - -+ #endif /* _UTSNAME */ -diff -rc tcl7.5b3.orig/generic/tclIO.c tcl7.5b3/generic/tclIO.c -*** tcl7.5b3.orig/generic/tclIO.c Fri Mar 8 12:59:53 1996 ---- tcl7.5b3/generic/tclIO.c Mon Mar 18 11:38:57 1996 -*************** -*** 2542,2548 **** - } - result = GetInput(chanPtr); - if (result != 0) { -! if (result == EWOULDBLOCK) { - chanPtr->flags |= CHANNEL_BLOCKED; - return copied; - } ---- 2542,2548 ---- - } - result = GetInput(chanPtr); - if (result != 0) { -! if (result == EAGAIN) { - chanPtr->flags |= CHANNEL_BLOCKED; - return copied; - } -diff -rc tcl7.5b3.orig/unix/tclLoadNext.c tcl7.5b3/unix/tclLoadNext.c -*** tcl7.5b3.orig/unix/tclLoadNext.c Sat Feb 17 16:16:42 1996 ---- tcl7.5b3/unix/tclLoadNext.c Mon Mar 18 10:02:36 1996 -*************** -*** 55,61 **** - char *files[]={fileName,NULL}; - NXStream *errorStream=NXOpenMemory(0,0,NX_READWRITE); - - -! if(!rld_load(errorStream,&header,files,NULL)) { - NXGetMemoryBuffer(errorStream,&data,&len,&maxlen); - Tcl_AppendResult(interp,"couldn't load file \"",fileName,"\": ",data,NULL); - NXCloseMemory(errorStream,NX_FREEBUFFER); ---- 55,61 ---- - char *files[]={fileName,NULL}; - NXStream *errorStream=NXOpenMemory(0,0,NX_READWRITE); - - -! if(objc_loadModules(files,errorStream,NULL,&header,NULL)) { - NXGetMemoryBuffer(errorStream,&data,&len,&maxlen); - Tcl_AppendResult(interp,"couldn't load file \"",fileName,"\": ",data,NULL); - NXCloseMemory(errorStream,NX_FREEBUFFER); -diff -rc tcl7.5b3.orig/unix/tclUnixFile.c tcl7.5b3/unix/tclUnixFile.c -*** tcl7.5b3.orig/unix/tclUnixFile.c Thu Mar 7 18:16:34 1996 ---- tcl7.5b3/unix/tclUnixFile.c Mon Mar 18 11:10:03 1996 -*************** -*** 31,37 **** ---- 31,41 ---- - - - static int executableNameExitHandlerSet = 0; - - -+ #if NeXT -+ #define waitpid( p, s, o) wait4( p, s, o, NULL) -+ #else - extern pid_t waitpid _ANSI_ARGS_((pid_t pid, int *stat_loc, int options)); -+ #endif - - - /* - * Static routines for this file: -diff -rc tcl7.5b3.orig/unix/tclUnixInit.c tcl7.5b3/unix/tclUnixInit.c -*** tcl7.5b3.orig/unix/tclUnixInit.c Sat Feb 17 16:16:39 1996 ---- tcl7.5b3/unix/tclUnixInit.c Mon Mar 18 11:50:28 1996 -*************** -*** 14,20 **** - #include "tclInt.h" - #include "tclPort.h" - #ifndef NO_UNAME -! # include <sys/utsname.h> - #endif - #if defined(__FreeBSD__) - #include <floatingpoint.h> ---- 14,24 ---- - #include "tclInt.h" - #include "tclPort.h" - #ifndef NO_UNAME -! # if NeXT -! # include "../compat/utsname.h" -! # else -! # include <sys/utsname.h> -! # endif - #endif - #if defined(__FreeBSD__) - #include <floatingpoint.h> -diff -rc tcl7.5b3.orig/unix/tclUnixPort.h tcl7.5b3/unix/tclUnixPort.h -*** tcl7.5b3.orig/unix/tclUnixPort.h Thu Mar 7 18:16:31 1996 ---- tcl7.5b3/unix/tclUnixPort.h Mon Mar 18 11:53:14 1996 -*************** -*** 76,82 **** - */ - - - #include <sys/socket.h> /* struct sockaddr, SOCK_STREAM, ... */ -! #include <sys/utsname.h> /* uname system call. */ - #include <netinet/in.h> /* struct in_addr, struct sockaddr_in */ - #include <arpa/inet.h> /* inet_ntoa() */ - #include <netdb.h> /* gethostbyname() */ ---- 76,88 ---- - */ - - - #include <sys/socket.h> /* struct sockaddr, SOCK_STREAM, ... */ -! #ifndef NO_UNAME -! # if NeXT -! # include "../compat/utsname.h" -! # else -! # include <sys/utsname.h> /* uname system call. */ -! # endif -! #endif - #include <netinet/in.h> /* struct in_addr, struct sockaddr_in */ - #include <arpa/inet.h> /* inet_ntoa() */ - #include <netdb.h> /* gethostbyname() */ - --------------------------------------------- -SCO Unix 3.2.4 (ODT 3.0) --------------------------------------------- - -The macro va_start in /usr/include/stdarg.h is incorrectly terminated by -a semi-colon. This causes compile of generic/tclBasic.c to fail. The -best solution is to edit the definition of va_start to remove the `;'. -This will fix this file for anything you want to compile. If you don't have -permission to edit /usr/include/stdarg.h in place, copy it to the tcl unix -directory and change it there. - -Contact me directly if you have problems on SCO systems. -Mark Diekhans <markd@grizzly.com> - --------------------------------------------- -SCO Unix 3.2.5 (ODT 5.0) --------------------------------------------- - -Expect failures from socket tests 2.9 and 3.1. - -Contact me directly if you have problems on SCO systems. -Mark Diekhans <markd@grizzly.com> - --------------------------------------------- -Linux 1.2.13 (gcc 2.7.0, libc.so.5.0.9) --------------------------------------------- - -Symptoms: - -* Some extensions could not be loaded dynamically, most - prominently Blt 2.0 - - The given error message essentially said: - Could not resolve symbol '__eprintf'. - - (This procedure is used by the macro 'assert') - -Cause - -* '__eprintf' is defined in 'libgcc.a', not 'libc.so.x.y'. - It is therefore impossible to load it dynamically. - -* Neither tcl nor tk make use of 'assert', thereby - preventing a static linkage. - -Workaround - -* I included <assert.h> in 'tclAppInit.c' / 'tkAppInit.c' - and then executed 'assert (argc)' just before the call - to Tcl_Main / Tk_Main. - - This forced the static linkage of '__eprintf' and - everything went fine from then on. - - (Something like 'assert (1)', 'assert (a==a)' is not - sufficient, it will be optimized away). + http://www.scriptics.com/software/install.html#Database +If you port Tcl or Tk to a new platform, you can share any information +you might have by adding a new entry to this database. diff --git a/unix/tclAppInit.c b/unix/tclAppInit.c index 7e46ad5..b37189e 100644 --- a/unix/tclAppInit.c +++ b/unix/tclAppInit.c @@ -6,11 +6,12 @@ * * Copyright (c) 1993 The Regents of the University of California. * Copyright (c) 1994-1997 Sun Microsystems, Inc. + * Copyright (c) 1998-1999 by Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclAppInit.c,v 1.4 1999/02/03 02:58:26 stanton Exp $ + * RCS: @(#) $Id: tclAppInit.c,v 1.5 1999/04/16 00:48:03 stanton Exp $ */ #ifdef TCL_XT_TEST @@ -29,11 +30,19 @@ int *tclDummyMathPtr = (int *) matherr; #ifdef TCL_TEST + +#include "tclInt.h" + extern int Procbodytest_Init _ANSI_ARGS_((Tcl_Interp *interp)); extern int Procbodytest_SafeInit _ANSI_ARGS_((Tcl_Interp *interp)); extern int TclObjTest_Init _ANSI_ARGS_((Tcl_Interp *interp)); extern int Tcltest_Init _ANSI_ARGS_((Tcl_Interp *interp)); +#ifdef TCL_THREADS +extern int TclThread_Init _ANSI_ARGS_((Tcl_Interp *interp)); +#endif + #endif /* TCL_TEST */ + #ifdef TCL_XT_TEST extern int Tclxttest_Init _ANSI_ARGS_((Tcl_Interp *interp)); #endif @@ -60,9 +69,20 @@ main(argc, argv) int argc; /* Number of command-line arguments. */ char **argv; /* Values of command-line arguments. */ { +#ifdef TCL_TEST + /* + * Pass the build time location of the tcl library (to find init.tcl) + */ + Tcl_Obj *path; + path = Tcl_NewStringObj(TCL_BUILDTIME_LIBRARY, -1); + TclSetLibraryPath(Tcl_NewListObj(1,&path)); + +#endif + #ifdef TCL_XT_TEST XtToolkitInitialize(); #endif + Tcl_Main(argc, argv, Tcl_AppInit); return 0; /* Needed only to prevent compiler warning. */ } @@ -78,7 +98,7 @@ main(argc, argv) * * Results: * Returns a standard Tcl completion code, and leaves an error - * message in interp->result if an error occurs. + * message in the interp's result if an error occurs. * * Side effects: * Depends on the startup script. @@ -108,6 +128,11 @@ Tcl_AppInit(interp) if (TclObjTest_Init(interp) == TCL_ERROR) { return TCL_ERROR; } +#ifdef TCL_THREADS + if (TclThread_Init(interp) == TCL_ERROR) { + return TCL_ERROR; + } +#endif if (Procbodytest_Init(interp) == TCL_ERROR) { return TCL_ERROR; } diff --git a/unix/tclLoadAix.c b/unix/tclLoadAix.c index 73bf5c5..8fe28a1 100644 --- a/unix/tclLoadAix.c +++ b/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. * - * RCS: @(#) $Id: tclLoadAix.c,v 1.2 1998/09/14 18:40:16 stanton Exp $ + * RCS: @(#) $Id: tclLoadAix.c,v 1.3 1999/04/16 00:48:04 stanton Exp $ * * Note: this file has been altered from the original in a few * ways in order to work properly with Tcl. @@ -213,7 +213,7 @@ static void caterr(char *s) while (*p >= '0' && *p <= '9') p++; - switch(atoi(s)) { + switch(atoi(s)) { /* INTL: "C", UTF safe. */ case L_ERROR_TOOMANY: strcat(errbuf, "to many errors"); break; @@ -234,7 +234,7 @@ static void caterr(char *s) strcat(errbuf, p); break; case L_ERROR_ERRNO: - strcat(errbuf, strerror(atoi(++p))); + strcat(errbuf, strerror(atoi(++p))); /* INTL: "C", UTF safe. */ break; default: strcat(errbuf, s); diff --git a/unix/tclLoadAout.c b/unix/tclLoadAout.c index d0a7700..8b6da69 100644 --- a/unix/tclLoadAout.c +++ b/unix/tclLoadAout.c @@ -14,7 +14,7 @@ * and Design Engineering (MADE) Initiative through ARPA contract * F33615-94-C-4400. * - * RCS: @(#) $Id: tclLoadAout.c,v 1.2 1998/09/14 18:40:16 stanton Exp $ + * RCS: @(#) $Id: tclLoadAout.c,v 1.3 1999/04/16 00:48:04 stanton Exp $ */ #include "tclInt.h" @@ -97,7 +97,7 @@ static void UnlinkSymbolTable _ANSI_ARGS_((void)); /* *---------------------------------------------------------------------- * - * TclLoadFile -- + * TclpLoadFile -- * * Dynamically loads a binary code file into memory and returns * the addresses of two procedures within that file, if they @@ -105,7 +105,7 @@ static void UnlinkSymbolTable _ANSI_ARGS_((void)); * * Results: * A standard Tcl completion code. If an error occurs, an error - * message is left in interp->result. *proc1Ptr and *proc2Ptr + * message is left in the interp's result. *proc1Ptr and *proc2Ptr * are filled in with the addresses of the symbols given by * *sym1 and *sym2, or NULL if those symbols can't be found. * @@ -136,15 +136,18 @@ static void UnlinkSymbolTable _ANSI_ARGS_((void)); */ int -TclLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr) +TclpLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr, clientDataPtr) Tcl_Interp *interp; /* Used for error reporting. */ char *fileName; /* Name of the file containing the desired - * code. */ + * code (UTF-8). */ char *sym1, *sym2; /* Names of two procedures to look up in * the file's symbol table. */ Tcl_PackageInitProc **proc1Ptr, **proc2Ptr; /* Where to return the addresses corresponding * to sym1 and sym2. */ + ClientData *clientDataPtr; /* Filled with token for dynamically loaded + * file which will be passed back to + * TclpUnloadFile() to unload the file. */ { char * inputSymbolTable; /* Name of the file containing the * symbol table from the last link. */ @@ -163,6 +166,8 @@ TclLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr) int status; /* Status return from Tcl_ calls */ char * p; + *clientDataPtr = NULL; + /* Find the file that contains the symbols for the run-time link. */ if (SymbolTableFile != NULL) { @@ -313,8 +318,8 @@ TclLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr) * * Results: * A standard Tcl completion code. If an error occurs, - * an error message is left in interp->result. The -l and -L flags - * are concatenated onto the dynamic string `buf'. + * an error message is left in the interp's result. The -l and -L + * flags are concatenated onto the dynamic string `buf'. * *------------------------------------------------------------------------ */ @@ -328,10 +333,16 @@ FindLibraries (interp, fileName, buf) FILE * f; /* The load module */ int c; /* Byte from the load module */ char * p; + Tcl_DString ds; + CONST char *native; /* Open the load module */ - if ((f = fopen (fileName, "rb")) == NULL) { + native = Tcl_UtfToExternalDString(NULL, fileName, -1, &ds); + f = fopen(native, "rb"); /* INTL: Native. */ + Tcl_DStringFree(&ds); + + if (f == NULL) { Tcl_AppendResult (interp, "couldn't open \"", fileName, "\": ", Tcl_PosixError (interp), (char *) NULL); return TCL_ERROR; @@ -407,6 +418,33 @@ UnlinkSymbolTable () /* *---------------------------------------------------------------------- * + * TclpUnloadFile -- + * + * Unloads a dynamically loaded binary code file from memory. + * Code pointers in the formerly loaded file are no longer valid + * after calling this function. + * + * Results: + * None. + * + * Side effects: + * Does nothing. Can anything be done? + * + *---------------------------------------------------------------------- + */ + +void +TclpUnloadFile(clientData) + ClientData clientData; /* ClientData returned by a previous call + * to TclpLoadFile(). The clientData is + * a token that represents the loaded + * file. */ +{ +} + +/* + *---------------------------------------------------------------------- + * * TclGuessPackageName -- * * If the "load" command is invoked without providing a package @@ -432,6 +470,7 @@ TclGuessPackageName(fileName, bufPtr) * package name to this if possible. */ { char *p, *q, *r; + int srcOff, dstOff; if (q = strrchr(fileName,'/')) { q++; @@ -457,14 +496,12 @@ TclGuessPackageName(fileName, bufPtr) 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)); - } - } + /* + * Capitalize the string and then recompute the length. + */ + + Tcl_UtfToTitle(r); + Tcl_DStringSetLength(bufPtr, strlen(Tcl_DStringValue(bufPtr))); return 1; } diff --git a/unix/tclLoadDl.c b/unix/tclLoadDl.c index 159d388..2a868d8 100644 --- a/unix/tclLoadDl.c +++ b/unix/tclLoadDl.c @@ -5,12 +5,12 @@ * works with the "dlopen" and "dlsym" library procedures for * dynamic loading. * - * 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. * - * RCS: @(#) $Id: tclLoadDl.c,v 1.2 1998/09/14 18:40:16 stanton Exp $ + * RCS: @(#) $Id: tclLoadDl.c,v 1.3 1999/04/16 00:48:04 stanton Exp $ */ #include "tclInt.h" @@ -36,9 +36,9 @@ #endif /* - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- * - * TclLoadFile -- + * TclpLoadFile -- * * Dynamically loads a binary code file into memory and returns * the addresses of two procedures within that file, if they @@ -46,18 +46,18 @@ * * Results: * A standard Tcl completion code. If an error occurs, an error - * message is left in interp->result. *proc1Ptr and *proc2Ptr + * message is left in the interp's result. *proc1Ptr and *proc2Ptr * are filled in with the addresses of the symbols given by * *sym1 and *sym2, or NULL if those symbols can't be found. * * Side effects: * New code suddenly appears in memory. * - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- */ int -TclLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr) +TclpLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr, clientDataPtr) Tcl_Interp *interp; /* Used for error reporting. */ char *fileName; /* Name of the file containing the desired * code. */ @@ -66,11 +66,20 @@ TclLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr) Tcl_PackageInitProc **proc1Ptr, **proc2Ptr; /* Where to return the addresses corresponding * to sym1 and sym2. */ + ClientData *clientDataPtr; /* Filled with token for dynamically loaded + * file which will be passed back to + * TclpUnloadFile() to unload the file. */ { VOID *handle; - Tcl_DString newName; + Tcl_DString newName, ds; + char *native; - handle = dlopen(fileName, RTLD_NOW | RTLD_GLOBAL); + native = Tcl_UtfToExternalDString(NULL, fileName, -1, &ds); + handle = dlopen(native, RTLD_NOW | RTLD_GLOBAL); /* INTL: Native. */ + Tcl_DStringFree(&ds); + + *clientDataPtr = (ClientData) handle; + if (handle == NULL) { Tcl_AppendResult(interp, "couldn't load file \"", fileName, "\": ", dlerror(), (char *) NULL); @@ -83,30 +92,69 @@ TclLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr) * with the underscore. */ - *proc1Ptr = (Tcl_PackageInitProc *) dlsym(handle, (char *) sym1); + native = Tcl_UtfToExternalDString(NULL, sym1, -1, &ds); + *proc1Ptr = (Tcl_PackageInitProc *) dlsym(handle, /* INTL: Native. */ + native); if (*proc1Ptr == NULL) { Tcl_DStringInit(&newName); Tcl_DStringAppend(&newName, "_", 1); - Tcl_DStringAppend(&newName, sym1, -1); - *proc1Ptr = (Tcl_PackageInitProc *) dlsym(handle, - Tcl_DStringValue(&newName)); + native = Tcl_DStringAppend(&newName, native, -1); + *proc1Ptr = (Tcl_PackageInitProc *) dlsym(handle, /* INTL: Native. */ + native); Tcl_DStringFree(&newName); } - *proc2Ptr = (Tcl_PackageInitProc *) dlsym(handle, (char *) sym2); + Tcl_DStringFree(&ds); + + native = Tcl_UtfToExternalDString(NULL, sym2, -1, &ds); + *proc2Ptr = (Tcl_PackageInitProc *) dlsym(handle, /* INTL: Native. */ + native); if (*proc2Ptr == NULL) { Tcl_DStringInit(&newName); Tcl_DStringAppend(&newName, "_", 1); - Tcl_DStringAppend(&newName, sym2, -1); - *proc2Ptr = (Tcl_PackageInitProc *) dlsym(handle, - Tcl_DStringValue(&newName)); + native = Tcl_DStringAppend(&newName, native, -1); + *proc2Ptr = (Tcl_PackageInitProc *) dlsym(handle, /* INTL: Native. */ + native); Tcl_DStringFree(&newName); } + Tcl_DStringFree(&ds); + return TCL_OK; } /* *---------------------------------------------------------------------- * + * TclpUnloadFile -- + * + * Unloads a dynamically loaded binary code file from memory. + * Code pointers in the formerly loaded file are no longer valid + * after calling this function. + * + * Results: + * None. + * + * Side effects: + * Code removed from memory. + * + *---------------------------------------------------------------------- + */ + +void +TclpUnloadFile(clientData) + ClientData clientData; /* ClientData returned by a previous call + * to TclpLoadFile(). The clientData is + * a token that represents the loaded + * file. */ +{ + VOID *handle; + + handle = (VOID *) clientData; + dlclose(handle); +} + +/* + *---------------------------------------------------------------------- + * * TclGuessPackageName -- * * If the "load" command is invoked without providing a package diff --git a/unix/tclLoadDld.c b/unix/tclLoadDld.c index 4b3ed36..1f9e702 100644 --- a/unix/tclLoadDld.c +++ b/unix/tclLoadDld.c @@ -7,12 +7,12 @@ * dld-3.2.7. This file probably isn't needed anymore, since it * makes more sense to use "dl_open" etc. * - * Copyright (c) 1995 Sun Microsystems, Inc. + * Copyright (c) 1995-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclLoadDld.c,v 1.2 1998/09/14 18:40:16 stanton Exp $ + * RCS: @(#) $Id: tclLoadDld.c,v 1.3 1999/04/16 00:48:04 stanton Exp $ */ #include "tclInt.h" @@ -30,7 +30,7 @@ /* *---------------------------------------------------------------------- * - * TclLoadFile -- + * TclpLoadFile -- * * Dynamically loads a binary code file into memory and returns * the addresses of two procedures within that file, if they @@ -38,7 +38,7 @@ * * Results: * A standard Tcl completion code. If an error occurs, an error - * message is left in interp->result. *proc1Ptr and *proc2Ptr + * message is left in the interp's result. *proc1Ptr and *proc2Ptr * are filled in with the addresses of the symbols given by * *sym1 and *sym2, or NULL if those symbols can't be found. * @@ -49,7 +49,7 @@ */ int -TclLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr) +TclpLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr, clientDataPtr) Tcl_Interp *interp; /* Used for error reporting. */ char *fileName; /* Name of the file containing the desired * code. */ @@ -58,6 +58,9 @@ TclLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr) Tcl_PackageInitProc **proc1Ptr, **proc2Ptr; /* Where to return the addresses corresponding * to sym1 and sym2. */ + ClientData *clientDataPtr; /* Filled with token for dynamically loaded + * file which will be passed back to + * TclpUnloadFile() to unload the file. */ { static int firstTime = 1; int returnCode; @@ -91,12 +94,46 @@ TclLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr) } *proc1Ptr = (Tcl_PackageInitProc *) dld_get_func(sym1); *proc2Ptr = (Tcl_PackageInitProc *) dld_get_func(sym2); + *clientDataPtr = strcpy( + (char *) ckalloc((unsigned) (strlen(fileName) + 1)), fileName); return TCL_OK; } /* *---------------------------------------------------------------------- * + * TclpUnloadFile -- + * + * Unloads a dynamically loaded binary code file from memory. + * Code pointers in the formerly loaded file are no longer valid + * after calling this function. + * + * Results: + * None. + * + * Side effects: + * Code removed from memory. + * + *---------------------------------------------------------------------- + */ + +void +TclpUnloadFile(clientData) + ClientData clientData; /* ClientData returned by a previous call + * to TclpLoadFile(). The clientData is + * a token that represents the loaded + * file. */ +{ + char *fileName; + + handle = (char *) clientData; + dld_unlink_by_file(handle, 0); + ckfree(handle); +} + +/* + *---------------------------------------------------------------------- + * * TclGuessPackageName -- * * If the "load" command is invoked without providing a package diff --git a/unix/tclLoadNext.c b/unix/tclLoadNext.c index ade9739..f29c996 100644 --- a/unix/tclLoadNext.c +++ b/unix/tclLoadNext.c @@ -5,12 +5,12 @@ * works with NeXTs rld_* dynamic loading. This file provided * by Pedja Bogdanovich. * - * 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. * - * RCS: @(#) $Id: tclLoadNext.c,v 1.2 1998/09/14 18:40:17 stanton Exp $ + * RCS: @(#) $Id: tclLoadNext.c,v 1.3 1999/04/16 00:48:04 stanton Exp $ */ #include "tclInt.h" @@ -20,7 +20,7 @@ /* *---------------------------------------------------------------------- * - * TclLoadFile -- + * TclpLoadFile -- * * Dynamically loads a binary code file into memory and returns * the addresses of two procedures within that file, if they @@ -28,7 +28,7 @@ * * Results: * A standard Tcl completion code. If an error occurs, an error - * message is left in interp->result. *proc1Ptr and *proc2Ptr + * message is left in the interp's result. *proc1Ptr and *proc2Ptr * are filled in with the addresses of the symbols given by * *sym1 and *sym2, or NULL if those symbols can't be found. * @@ -39,7 +39,7 @@ */ int -TclLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr) +TclpLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr, clientDataPtr) Tcl_Interp *interp; /* Used for error reporting. */ char *fileName; /* Name of the file containing the desired * code. */ @@ -48,6 +48,9 @@ TclLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr) Tcl_PackageInitProc **proc1Ptr, **proc2Ptr; /* Where to return the addresses corresponding * to sym1 and sym2. */ + ClientData *clientDataPtr; /* Filled with token for dynamically loaded + * file which will be passed back to + * TclpUnloadFile() to unload the file. */ { struct mach_header *header; char *data; @@ -76,6 +79,7 @@ TclLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr) sym[0]='_'; sym[1]=0; strcat(sym,sym2); rld_lookup(NULL,sym,(unsigned long *)proc2Ptr); } + *clientDataPtr = NULL; return TCL_OK; } @@ -83,6 +87,33 @@ TclLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr) /* *---------------------------------------------------------------------- * + * TclpUnloadFile -- + * + * Unloads a dynamically loaded binary code file from memory. + * Code pointers in the formerly loaded file are no longer valid + * after calling this function. + * + * Results: + * None. + * + * Side effects: + * Does nothing. Can anything be done? + * + *---------------------------------------------------------------------- + */ + +void +TclpUnloadFile(clientData) + ClientData clientData; /* ClientData returned by a previous call + * to TclpLoadFile(). The clientData is + * a token that represents the loaded + * file. */ +{ +} + +/* + *---------------------------------------------------------------------- + * * TclGuessPackageName -- * * If the "load" command is invoked without providing a package diff --git a/unix/tclLoadOSF.c b/unix/tclLoadOSF.c index ebb06f0..9e8b3ad 100644 --- a/unix/tclLoadOSF.c +++ b/unix/tclLoadOSF.c @@ -26,12 +26,12 @@ * * John Robert LoVerso <loverso@freebsd.osf.org> * - * 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. * - * RCS: @(#) $Id: tclLoadOSF.c,v 1.2 1998/09/14 18:40:17 stanton Exp $ + * RCS: @(#) $Id: tclLoadOSF.c,v 1.3 1999/04/16 00:48:04 stanton Exp $ */ #include "tclInt.h" @@ -41,7 +41,7 @@ /* *---------------------------------------------------------------------- * - * TclLoadFile -- + * TclpLoadFile -- * * Dynamically loads a binary code file into memory and returns * the addresses of two procedures within that file, if they @@ -49,7 +49,7 @@ * * Results: * A standard Tcl completion code. If an error occurs, an error - * message is left in interp->result. *proc1Ptr and *proc2Ptr + * message is left in the interp's result. *proc1Ptr and *proc2Ptr * are filled in with the addresses of the symbols given by * *sym1 and *sym2, or NULL if those symbols can't be found. * @@ -60,7 +60,7 @@ */ int -TclLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr) +TclpLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr, clientDataPtr) Tcl_Interp *interp; /* Used for error reporting. */ char *fileName; /* Name of the file containing the desired * code. */ @@ -69,6 +69,9 @@ TclLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr) Tcl_PackageInitProc **proc1Ptr, **proc2Ptr; /* Where to return the addresses corresponding * to sym1 and sym2. */ + ClientData *clientDataPtr; /* Filled with token for dynamically loaded + * file which will be passed back to + * TclpUnloadFile() to unload the file. */ { ldr_module_t lm; char *pkg; @@ -80,6 +83,8 @@ TclLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr) return TCL_ERROR; } + *clientDataPtr = NULL; + /* * My convention is to use a [OSF loader] package name the same as shlib, * since the idiots never implemented ldr_lookup() and it is otherwise @@ -100,6 +105,33 @@ TclLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr) /* *---------------------------------------------------------------------- * + * TclpUnloadFile -- + * + * Unloads a dynamically loaded binary code file from memory. + * Code pointers in the formerly loaded file are no longer valid + * after calling this function. + * + * Results: + * None. + * + * Side effects: + * Does nothing. Can anything be done? + * + *---------------------------------------------------------------------- + */ + +void +TclpUnloadFile(clientData) + ClientData clientData; /* ClientData returned by a previous call + * to TclpLoadFile(). The clientData is + * a token that represents the loaded + * file. */ +{ +} + +/* + *---------------------------------------------------------------------- + * * TclGuessPackageName -- * * If the "load" command is invoked without providing a package diff --git a/unix/tclLoadShl.c b/unix/tclLoadShl.c index ee6e419..3330919 100644 --- a/unix/tclLoadShl.c +++ b/unix/tclLoadShl.c @@ -5,12 +5,12 @@ * with the "shl_load" and "shl_findsym" library procedures for * dynamic loading (e.g. for HP machines). * - * 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. * - * RCS: @(#) $Id: tclLoadShl.c,v 1.2 1998/09/14 18:40:17 stanton Exp $ + * RCS: @(#) $Id: tclLoadShl.c,v 1.3 1999/04/16 00:48:04 stanton Exp $ */ #include <dl.h> @@ -28,7 +28,7 @@ /* *---------------------------------------------------------------------- * - * TclLoadFile -- + * TclpLoadFile -- * * Dynamically loads a binary code file into memory and returns * the addresses of two procedures within that file, if they @@ -36,7 +36,7 @@ * * Results: * A standard Tcl completion code. If an error occurs, an error - * message is left in interp->result. *proc1Ptr and *proc2Ptr + * message is left in the interp's result. *proc1Ptr and *proc2Ptr * are filled in with the addresses of the symbols given by * *sym1 and *sym2, or NULL if those symbols can't be found. * @@ -47,7 +47,7 @@ */ int -TclLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr) +TclpLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr, clientDataPtr) Tcl_Interp *interp; /* Used for error reporting. */ char *fileName; /* Name of the file containing the desired * code. */ @@ -56,16 +56,30 @@ TclLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr) Tcl_PackageInitProc **proc1Ptr, **proc2Ptr; /* Where to return the addresses corresponding * to sym1 and sym2. */ + ClientData *clientDataPtr; /* Filled with token for dynamically loaded + * file which will be passed back to + * TclpUnloadFile() to unload the file. */ { shl_t handle; Tcl_DString newName; - handle = shl_load(fileName, BIND_IMMEDIATE, 0L); + /* + * The flags below used to be BIND_IMMEDIATE; they were changed at + * the suggestion of Wolfgang Kechel (wolfgang@prs.de): "This + * enables verbosity for missing symbols when loading a shared lib + * and allows to load libtk8.0.sl into tclsh8.0 without problems. + * In general, this delays resolving symbols until they are actually + * needed. Shared libs do no longer need all libraries linked in + * when they are build." + */ + + handle = shl_load(fileName, BIND_DEFERRED|BIND_VERBOSE, 0L); if (handle == NULL) { Tcl_AppendResult(interp, "couldn't load file \"", fileName, "\": ", Tcl_PosixError(interp), (char *) NULL); return TCL_ERROR; } + *clientDataPtr = (ClientData) handle; /* * Some versions of the HP system software still use "_" at the @@ -101,6 +115,37 @@ TclLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr) /* *---------------------------------------------------------------------- * + * TclpUnloadFile -- + * + * Unloads a dynamically loaded binary code file from memory. + * Code pointers in the formerly loaded file are no longer valid + * after calling this function. + * + * Results: + * None. + * + * Side effects: + * Code removed from memory. + * + *---------------------------------------------------------------------- + */ + +void +TclpUnloadFile(clientData) + ClientData clientData; /* ClientData returned by a previous call + * to TclpLoadFile(). The clientData is + * a token that represents the loaded + * file. */ +{ + shl_t handle; + + handle = (shl_t) clientData; + shl_unload(handle); +} + +/* + *---------------------------------------------------------------------- + * * TclGuessPackageName -- * * If the "load" command is invoked without providing a package diff --git a/unix/tclMtherr.c b/unix/tclMtherr.c index 96051bf..d1150f6 100644 --- a/unix/tclMtherr.c +++ b/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. * - * RCS: @(#) $Id: tclMtherr.c,v 1.2 1998/09/14 18:40:17 stanton Exp $ + * RCS: @(#) $Id: tclMtherr.c,v 1.3 1999/04/16 00:48:04 stanton Exp $ */ #include "tclInt.h" @@ -29,15 +29,6 @@ extern int errno; /* Use errno from tclExecute.c. */ #endif /* - * The following variable is secretly shared with Tcl so we can - * tell if expression evaluation is in progress. If not, matherr - * just emulates the default behavior, which includes printing - * a message. - */ - -extern int tcl_MathInProgress; - -/* * The following definitions allow matherr to compile on systems * that don't really support it. The compiled procedure is bogus, * but it will never be executed on these systems anyway. @@ -74,7 +65,7 @@ int matherr(xPtr) struct exception *xPtr; /* Describes error that occurred. */ { - if (!tcl_MathInProgress) { + if (TclMathInProgress()) { return 0; } if ((xPtr->type == DOMAIN) || (xPtr->type == SING)) { diff --git a/unix/tclUnixChan.c b/unix/tclUnixChan.c index 2759a41..4da4f1f 100644 --- a/unix/tclUnixChan.c +++ b/unix/tclUnixChan.c @@ -5,11 +5,12 @@ * pipes and TCP sockets. * * Copyright (c) 1995-1997 Sun Microsystems, Inc. + * Copyright (c) 1998-1999 by Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclUnixChan.c,v 1.9 1999/02/03 00:51:20 stanton Exp $ + * RCS: @(#) $Id: tclUnixChan.c,v 1.10 1999/04/16 00:48:04 stanton Exp $ */ #include "tclInt.h" /* Internal definitions for Tcl. */ @@ -40,31 +41,32 @@ #undef FLUSHO #undef PENDIN +#define SUPPORTS_TTY + #ifdef USE_TERMIOS # include <termios.h> +# define IOSTATE struct termios +# define GETIOSTATE(fd, statePtr) tcgetattr((fd), (statePtr)) +# define SETIOSTATE(fd, statePtr) tcsetattr((fd), TCSADRAIN, (statePtr)) #else /* !USE_TERMIOS */ #ifdef USE_TERMIO # include <termio.h> +# define IOSTATE struct termio +# define GETIOSTATE(fd, statePtr) ioctl((fd), TCGETA, (statePtr)) +# define SETIOSTATE(fd, statePtr) ioctl((fd), TCSETAW, (statePtr)) #else /* !USE_TERMIO */ #ifdef USE_SGTTY # include <sgtty.h> -#endif /* USE_SGTTY */ +# define IOSTATE struct sgttyb +# define GETIOSTATE(fd, statePtr) ioctl((fd), TIOCGETP, (statePtr)) +# define SETIOSTATE(fd, statePtr) ioctl((fd), TIOCSETP, (statePtr)) +#else /* !USE_SGTTY */ +# undef SUPPORTS_TTY +#endif /* !USE_SGTTY */ #endif /* !USE_TERMIO */ #endif /* !USE_TERMIOS */ /* - * 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. */ @@ -78,11 +80,44 @@ typedef struct FileState { * file channels. */ } FileState; +#ifdef SUPPORTS_TTY + /* - * List of all file channels currently open. + * The following structure describes per-instance state of a tty-based + * channel. */ -static FileState *firstFilePtr = NULL; +typedef struct TtyState { + FileState fs; /* Per-instance state of the file + * descriptor. Must be the first field. */ + IOSTATE savedState; /* Initial state of device. Used to reset + * state when device closed. */ +} TtyState; + +/* + * The following structure is used to set or get the serial port + * attributes in a platform-independant manner. + */ + +typedef struct TtyAttrs { + int baud; + int parity; + int data; + int stop; +} TtyAttrs; + +#endif /* !SUPPORTS_TTY */ + +typedef struct ThreadSpecificData { + /* + * List of all file channels currently open. This is per thread and is + * used to match up fd's to channels, which rarely occurs. + */ + + FileState *firstFilePtr; +} ThreadSpecificData; + +static Tcl_ThreadDataKey dataKey; /* * This structure describes per-instance state of a tcp based channel. @@ -170,20 +205,24 @@ static int TcpOutputProc _ANSI_ARGS_((ClientData instanceData, char *buf, int toWrite, int *errorCode)); static void TcpWatchProc _ANSI_ARGS_((ClientData instanceData, int mask)); -static int TtyParseMode _ANSI_ARGS_((Tcl_Interp *interp, - CONST char *mode, int *speedPtr, int *parityPtr, - int *dataPtr, int *stopPtr)); +#ifdef SUPPORTS_TTY +static int TtyCloseProc _ANSI_ARGS_((ClientData instanceData, + Tcl_Interp *interp)); static void TtyGetAttributes _ANSI_ARGS_((int fd, TtyAttrs *ttyPtr)); static int TtyGetOptionProc _ANSI_ARGS_((ClientData instanceData, Tcl_Interp *interp, char *optionName, Tcl_DString *dsPtr)); -static void TtyInit _ANSI_ARGS_((int fd)); +static FileState * TtyInit _ANSI_ARGS_((int fd)); +static int TtyParseMode _ANSI_ARGS_((Tcl_Interp *interp, + CONST char *mode, int *speedPtr, int *parityPtr, + int *dataPtr, int *stopPtr)); static void TtySetAttributes _ANSI_ARGS_((int fd, TtyAttrs *ttyPtr)); static int TtySetOptionProc _ANSI_ARGS_((ClientData instanceData, Tcl_Interp *interp, char *optionName, char *value)); +#endif /* SUPPORTS_TTY */ static int WaitForConnect _ANSI_ARGS_((TcpState *statePtr, int *errorCodePtr)); @@ -204,6 +243,7 @@ static Tcl_ChannelType fileChannelType = { FileGetHandleProc, /* Get OS handles out of channel. */ }; +#ifdef SUPPORTS_TTY /* * This structure describes the channel type structure for serial IO. * Note that this type is a subclass of the "file" type. @@ -212,7 +252,7 @@ static Tcl_ChannelType fileChannelType = { static Tcl_ChannelType ttyChannelType = { "tty", /* Type name. */ FileBlockModeProc, /* Set blocking/nonblocking mode.*/ - FileCloseProc, /* Close proc. */ + TtyCloseProc, /* Close proc. */ FileInputProc, /* Input proc. */ FileOutputProc, /* Output proc. */ NULL, /* Seek proc. */ @@ -221,6 +261,7 @@ static Tcl_ChannelType ttyChannelType = { FileWatchProc, /* Initialize notifier. */ FileGetHandleProc, /* Get OS handles out of channel. */ }; +#endif /* SUPPORTS_TTY */ /* * This structure describes the channel type structure for TCP socket @@ -403,15 +444,21 @@ FileCloseProc(instanceData, interp) FileState *fsPtr = (FileState *) instanceData; FileState **nextPtrPtr; int errorCode = 0; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); Tcl_DeleteFileHandler(fsPtr->fd); + + /* + * Do not close standard channels while in thread-exit. + */ + if (!TclInExit() || ((fsPtr->fd != 0) && (fsPtr->fd != 1) && (fsPtr->fd != 2))) { if (close(fsPtr->fd) < 0) { errorCode = errno; } } - for (nextPtrPtr = &firstFilePtr; (*nextPtrPtr) != NULL; + for (nextPtrPtr = &(tsdPtr->firstFilePtr); (*nextPtrPtr) != NULL; nextPtrPtr = &((*nextPtrPtr)->nextPtr)) { if ((*nextPtrPtr) == fsPtr) { (*nextPtrPtr) = fsPtr->nextPtr; @@ -508,7 +555,7 @@ FileWatchProc(instanceData, mask) * * FileGetHandleProc -- * - * Called from Tcl_GetChannelFile to retrieve OS handles from + * Called from Tcl_GetChannelHandle to retrieve OS handles from * a file based channel. * * Results: @@ -536,6 +583,37 @@ FileGetHandleProc(instanceData, direction, handlePtr) return TCL_ERROR; } } + +#ifdef SUPPORTS_TTY + +/* + *---------------------------------------------------------------------- + * + * TtyCloseProc -- + * + * This procedure is called from the generic IO level to perform + * channel-type-specific cleanup when a tty based channel is closed. + * + * Results: + * 0 if successful, errno if failed. + * + * Side effects: + * Restores the settings and closes the device of the channel. + * + *---------------------------------------------------------------------- + */ + +static int +TtyCloseProc(instanceData, interp) + ClientData instanceData; /* Tty state. */ + Tcl_Interp *interp; /* For error reporting - unused. */ +{ + TtyState *ttyPtr; + + ttyPtr = (TtyState *) instanceData; + SETIOSTATE(ttyPtr->fs.fd, &ttyPtr->savedState); + return FileCloseProc(instanceData, interp); +} /* *---------------------------------------------------------------------- @@ -545,7 +623,7 @@ FileGetHandleProc(instanceData, direction, handlePtr) * Sets an option on a channel. * * Results: - * A standard Tcl result. Also sets interp->result on error if + * A standard Tcl result. Also sets the interp's result on error if * interp is not NULL. * * Side effects: @@ -614,7 +692,7 @@ TtyGetOptionProc(instanceData, interp, optionName, dsPtr) { FileState *fsPtr = (FileState *) instanceData; unsigned int len; - char buf[32]; + char buf[3 * TCL_INTEGER_SPACE + 16]; TtyAttrs tty; if (optionName == NULL) { @@ -820,65 +898,6 @@ TtyGetBaud(speed) /* *--------------------------------------------------------------------------- * - * 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. @@ -899,79 +918,71 @@ TtyGetAttributes(fd, ttyPtr) TtyAttrs *ttyPtr; /* Buffer filled with serial port * attributes. */ { -#ifdef USE_TERMIOS - int parity, data; - struct termios termios; + IOSTATE iostate; + int baud, parity, data, stop; - tcgetattr(fd, &termios); - ttyPtr->baud = TtyGetBaud(cfgetospeed(&termios)); + GETIOSTATE(fd, &iostate); + +#ifdef USE_TERMIOS + baud = TtyGetBaud(cfgetospeed(&iostate)); parity = 'n'; #ifdef PAREXT - switch ((int) (termios.c_cflag & (PARENB | PARODD | PAREXT))) { + switch ((int) (iostate.c_cflag & (PARENB | PARODD | PAREXT))) { case PARENB : parity = 'e'; break; case PARENB | PARODD : parity = 'o'; break; case PARENB | PAREXT : parity = 's'; break; case PARENB | PARODD | PAREXT : parity = 'm'; break; } #else /* !PAREXT */ - switch ((int) (termios.c_cflag & (PARENB | PARODD))) { + switch ((int) (iostate.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; + data = iostate.c_cflag & CSIZE; + data = (data == CS5) ? 5 : (data == CS6) ? 6 : (data == CS7) ? 7 : 8; + + stop = (iostate.c_cflag & CSTOPB) ? 2 : 1; +#endif /* USE_TERMIOS */ - ttyPtr->stop = (termios.c_cflag & CSTOPB) ? 2 : 1; -#else /* !USE_TERMIOS */ #ifdef USE_TERMIO - int parity, data; - struct termio termio; + baud = TtyGetBaud(iostate.c_cflag & CBAUD); - ioctl(fd, TCGETA, &termio); - ttyPtr->baud = TtyGetBaud(termio.c_cflag & CBAUD); parity = 'n'; - switch (termio.c_cflag & (PARENB | PARODD | PAREXT)) { + switch (iostate.c_cflag & (PARENB | PARODD | PAREXT)) { case PARENB : parity = 'e'; break; case PARENB | PARODD : parity = 'o'; break; case PARENB | PAREXT : parity = 's'; break; case PARENB | PARODD | PAREXT : parity = 'm'; break; } - ttyPtr->parity = parity; - data = termio.c_cflag & CSIZE; - ttyPtr->data = (data == CS5) ? 5 : (data == CS6) ? 6 : - (data == CS7) ? 7 : 8; + data = iostate.c_cflag & CSIZE; + data = (data == CS5) ? 5 : (data == CS6) ? 6 : (data == CS7) ? 7 : 8; + + stop = (iostate.c_cflag & CSTOPB) ? 2 : 1; +#endif /* USE_TERMIO */ - ttyPtr->stop = (termio.c_cflag & CSTOPB) ? 2 : 1; -#else /* !USE_TERMIO */ #ifdef USE_SGTTY - int parity; - struct sgttyb sgttyb; + baud = TtyGetBaud(iostate.sg_ospeed); - ioctl(fd, TIOCGETP, &sgttyb); - ttyPtr->baud = TtyGetBaud(sgttyb.sg_ospeed); parity = 'n'; - if (sgttyb.sg_flags & EVENP) { + if (iostate.sg_flags & EVENP) { parity = 'e'; - } else if (sgttyb.sg_flags & ODDP) { + } else if (iostate.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 */ + + data = (iostate.sg_flags & (EVENP | ODDP)) ? 7 : 8; + + stop = 1; +#endif /* USE_SGTTY */ + + ttyPtr->baud = baud; + ttyPtr->parity = parity; + ttyPtr->data = data; + ttyPtr->stop = stop; } /* @@ -997,20 +1008,21 @@ TtySetAttributes(fd, ttyPtr) TtyAttrs *ttyPtr; /* Buffer containing new attributes for * serial port. */ { + IOSTATE iostate; + #ifdef USE_TERMIOS int parity, data, flag; - struct termios termios; - tcgetattr(fd, &termios); - cfsetospeed(&termios, TtyGetSpeed(ttyPtr->baud)); - cfsetispeed(&termios, TtyGetSpeed(ttyPtr->baud)); + GETIOSTATE(fd, &iostate); + cfsetospeed(&iostate, TtyGetSpeed(ttyPtr->baud)); + cfsetispeed(&iostate, TtyGetSpeed(ttyPtr->baud)); flag = 0; parity = ttyPtr->parity; if (parity != 'n') { flag |= PARENB; #ifdef PAREXT - termios.c_cflag &= ~PAREXT; + iostate.c_cflag &= ~PAREXT; if ((parity == 'm') || (parity == 's')) { flag |= PAREXT; } @@ -1025,18 +1037,17 @@ TtySetAttributes(fd, ttyPtr) flag |= CSTOPB; } - termios.c_cflag &= ~(PARENB | PARODD | CSIZE | CSTOPB); - termios.c_cflag |= flag; - tcsetattr(fd, TCSANOW, &termios); + iostate.c_cflag &= ~(PARENB | PARODD | CSIZE | CSTOPB); + iostate.c_cflag |= flag; + +#endif /* USE_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); + GETIOSTATE(fd, &iostate); + iostate.c_cflag &= ~CBAUD; + iostate.c_cflag |= TtyGetSpeed(ttyPtr->baud); flag = 0; parity = ttyPtr->parity; @@ -1055,31 +1066,29 @@ TtySetAttributes(fd, ttyPtr) flag |= CSTOPB; } - termio.c_cflag &= ~(PARENB | PARODD | PAREXT | CSIZE | CSTOPB); - termio.c_cflag |= flag; - ioctl(fd, TCSETAW, &termio); + iostate.c_cflag &= ~(PARENB | PARODD | PAREXT | CSIZE | CSTOPB); + iostate.c_cflag |= flag; + +#endif /* USE_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); + GETIOSTATE(fd, &iostate); + iostate.sg_ospeed = TtyGetSpeed(ttyPtr->baud); + iostate.sg_ispeed = TtyGetSpeed(ttyPtr->baud); parity = ttyPtr->parity; if (parity == 'e') { - sgttyb.sg_flags &= ~ODDP; - sgttyb.sg_flags |= EVENP; + iostate.sg_flags &= ~ODDP; + iostate.sg_flags |= EVENP; } else if (parity == 'o') { - sgttyb.sg_flags &= ~EVENP; - sgttyb.sg_flags |= ODDP; + iostate.sg_flags &= ~EVENP; + iostate.sg_flags |= ODDP; } - ioctl(fd, TIOCSETP, &sgttyb); #endif /* USE_SGTTY */ -#endif /* !USE_TERMIO */ -#endif /* !USE_TERMIOS */ + + SETIOSTATE(fd, &iostate); } /* @@ -1093,7 +1102,7 @@ TtySetAttributes(fd, ttyPtr) * 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). + * error message is left in the interp's result (if interp is non-NULL). * * Side effects: * None. @@ -1148,6 +1157,67 @@ TtyParseMode(interp, mode, speedPtr, parityPtr, dataPtr, stopPtr) } /* + *--------------------------------------------------------------------------- + * + * TtyInit -- + * + * Given file descriptor that refers to a serial port, + * initialize the serial port to a set of sane values so that + * Tcl can talk to a device located on the serial port. + * + * Results: + * None. + * + * Side effects: + * Serial device initialized to non-blocking raw mode, similar to + * sockets. All other modes can be simulated on top of this in Tcl. + * + *--------------------------------------------------------------------------- + */ + +static FileState * +TtyInit(fd) + int fd; /* Open file descriptor for serial port to + * be initialized. */ +{ + IOSTATE iostate; + TtyState *ttyPtr; + + ttyPtr = (TtyState *) ckalloc((unsigned) sizeof(TtyState)); + GETIOSTATE(fd, &ttyPtr->savedState); + + iostate = ttyPtr->savedState; + +#ifdef USE_TERMIOS + iostate.c_iflag = IGNBRK; + iostate.c_oflag = 0; + iostate.c_lflag = 0; + iostate.c_cflag |= CREAD; + iostate.c_cc[VMIN] = 1; + iostate.c_cc[VTIME] = 0; +#endif /* USE_TERMIOS */ + +#ifdef USE_TERMIO + iostate.c_iflag = IGNBRK; + iostate.c_oflag = 0; + iostate.c_lflag = 0; + iostate.c_cflag |= CREAD; + iostate.c_cc[VMIN] = 1; + iostate.c_cc[VTIME] = 0; +#endif /* USE_TERMIO */ + +#ifdef USE_SGTTY + iostate.sg_flags &= (EVENP | ODDP); + iostate.sg_flags |= RAW; +#endif /* USE_SGTTY */ + + SETIOSTATE(fd, &iostate); + + return &ttyPtr->fs; +} +#endif /* SUPPORTS_TTY */ + +/* *---------------------------------------------------------------------- * * TclpOpenFileChannel -- @@ -1157,7 +1227,7 @@ TtyParseMode(interp, mode, speedPtr, parityPtr, dataPtr, stopPtr) * Results: * The new channel or NULL. If NULL, the output argument * errorCodePtr is set to a POSIX error and an error message is - * left in interp->result if interp is not NULL. + * left in the interp's result if interp is not NULL. * * Side effects: * May open the channel and may cause creation of a file on the @@ -1179,9 +1249,11 @@ TclpOpenFileChannel(interp, fileName, modeString, permissions) { int fd, seekFlag, mode, channelPermissions; FileState *fsPtr; - char *nativeName, channelName[20]; - Tcl_DString buffer; + char *native, *translation; + char channelName[16 + TCL_INTEGER_SPACE]; + Tcl_DString ds, buffer; Tcl_ChannelType *channelTypePtr; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); mode = TclGetOpenMode(interp, modeString, &seekFlag); if (mode == -1) { @@ -1205,17 +1277,13 @@ TclpOpenFileChannel(interp, fileName, modeString, permissions) return NULL; } - nativeName = Tcl_TranslateFileName(interp, fileName, &buffer); - if (nativeName == NULL) { + native = Tcl_TranslateFileName(interp, fileName, &buffer); + if (native == NULL) { return NULL; } - fd = open(nativeName, mode, permissions); - - /* - * If nativeName is not NULL, the buffer is valid and we must free - * the storage. - */ - + native = Tcl_UtfToExternalDString(NULL, native, -1, &ds); + fd = open(native, mode, permissions); /* INTL: Native. */ + Tcl_DStringFree(&ds); Tcl_DStringFree(&buffer); if (fd < 0) { @@ -1235,12 +1303,7 @@ TclpOpenFileChannel(interp, fileName, modeString, permissions) sprintf(channelName, "file%d", fd); - fsPtr = (FileState *) ckalloc((unsigned) sizeof(FileState)); - fsPtr->nextPtr = firstFilePtr; - firstFilePtr = fsPtr; - fsPtr->validMask = channelPermissions | TCL_EXCEPTION; - fsPtr->fd = fd; - +#ifdef SUPPORTS_TTY if (isatty(fd)) { /* * Initialize the serial port to a set of sane parameters. @@ -1250,12 +1313,22 @@ TclpOpenFileChannel(interp, fileName, modeString, permissions) * then the serial driver would echo it back to the device, etc. */ - TtyInit(fd); + translation = "auto crlf"; channelTypePtr = &ttyChannelType; - } else { + fsPtr = TtyInit(fd); + } else +#endif /* SUPPORTS_TTY */ + { + translation = NULL; channelTypePtr = &fileChannelType; + fsPtr = (FileState *) ckalloc((unsigned) sizeof(FileState)); } + fsPtr->nextPtr = tsdPtr->firstFilePtr; + tsdPtr->firstFilePtr = fsPtr; + fsPtr->validMask = channelPermissions | TCL_EXCEPTION; + fsPtr->fd = fd; + fsPtr->channel = Tcl_CreateChannel(channelTypePtr, channelName, (ClientData) fsPtr, channelPermissions); @@ -1270,7 +1343,7 @@ TclpOpenFileChannel(interp, fileName, modeString, permissions) } } - if (channelTypePtr == &ttyChannelType) { + if (translation != NULL) { /* * Gotcha. Most modems need a "\r" at the end of the command * sequence. If you just send "at\n", the modem will not respond @@ -1280,7 +1353,7 @@ TclpOpenFileChannel(interp, fileName, modeString, permissions) */ if (Tcl_SetChannelOption(interp, fsPtr->channel, "-translation", - "auto crlf") != TCL_OK) { + translation) != TCL_OK) { Tcl_Close(NULL, fsPtr->channel); return NULL; } @@ -1312,8 +1385,9 @@ Tcl_MakeFileChannel(handle, mode) * TCL_WRITABLE to indicate file mode. */ { FileState *fsPtr; - char channelName[20]; + char channelName[16 + TCL_INTEGER_SPACE]; int fd = (int) handle; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); if (mode == 0) { return NULL; @@ -1326,15 +1400,17 @@ Tcl_MakeFileChannel(handle, mode) * If the fd is used, but the mode doesn't match, return NULL. */ - for (fsPtr = firstFilePtr; fsPtr != NULL; fsPtr = fsPtr->nextPtr) { + for (fsPtr = tsdPtr->firstFilePtr; fsPtr != NULL; fsPtr = fsPtr->nextPtr) { if (fsPtr->fd == fd) { - return (mode == fsPtr->validMask) ? fsPtr->channel : NULL; + return ((mode|TCL_EXCEPTION) == fsPtr->validMask) ? + fsPtr->channel : NULL; } } fsPtr = (FileState *) ckalloc((unsigned) sizeof(FileState)); - fsPtr->nextPtr = firstFilePtr; - firstFilePtr = fsPtr; + fsPtr->nextPtr = tsdPtr->firstFilePtr; + tsdPtr->firstFilePtr = fsPtr; + fsPtr->fd = fd; fsPtr->validMask = mode | TCL_EXCEPTION; fsPtr->channel = Tcl_CreateChannel(&fileChannelType, channelName, @@ -1604,7 +1680,7 @@ TcpCloseProc(instanceData, interp) * closing code that called this function, so we do not have to * delete them here. */ - + Tcl_DeleteFileHandler(statePtr->fd); if (close(statePtr->fd) < 0) { @@ -1653,47 +1729,51 @@ TcpGetOptionProc(instanceData, interp, optionName, dsPtr) struct hostent *hostEntPtr; int size = sizeof(struct sockaddr_in); size_t len = 0; - char buf[128]; + char buf[TCL_INTEGER_SPACE]; if (optionName != (char *) NULL) { len = strlen(optionName); } if ((len > 1) && (optionName[1] == 'e') && - (strncmp(optionName, "-error", len) == 0)) { - int optlen; - int err, ret; + (strncmp(optionName, "-error", len) == 0)) { + int optlen; + int err, ret; - optlen = sizeof(int); - ret = getsockopt(statePtr->fd, SOL_SOCKET, SO_ERROR, - (char *)&err, &optlen); - if (ret < 0) { - err = errno; - } - if (err != 0) { - Tcl_DStringAppend(dsPtr, Tcl_ErrnoMsg(err), -1); - } + optlen = sizeof(int); + ret = getsockopt(statePtr->fd, SOL_SOCKET, SO_ERROR, + (char *)&err, &optlen); + if (ret < 0) { + err = errno; + } + if (err != 0) { + Tcl_DStringAppend(dsPtr, Tcl_ErrnoMsg(err), -1); + } return TCL_OK; } if ((len == 0) || ((len > 1) && (optionName[1] == 'p') && (strncmp(optionName, "-peername", len) == 0))) { - if (getpeername(statePtr->fd, (struct sockaddr *) &peername, &size) - >= 0) { + if (getpeername(statePtr->fd, (struct sockaddr *) &peername, + &size) >= 0) { if (len == 0) { Tcl_DStringAppendElement(dsPtr, "-peername"); Tcl_DStringStartSublist(dsPtr); } Tcl_DStringAppendElement(dsPtr, inet_ntoa(peername.sin_addr)); - hostEntPtr = gethostbyaddr((char *) &(peername.sin_addr), - sizeof(peername.sin_addr), AF_INET); - if (hostEntPtr != (struct hostent *) NULL) { - Tcl_DStringAppendElement(dsPtr, hostEntPtr->h_name); + hostEntPtr = gethostbyaddr( /* INTL: Native. */ + (char *) &peername.sin_addr, + sizeof(peername.sin_addr), AF_INET); + if (hostEntPtr != NULL) { + Tcl_DString ds; + + Tcl_ExternalToUtfDString(NULL, hostEntPtr->h_name, -1, &ds); + Tcl_DStringAppendElement(dsPtr, Tcl_DStringValue(&ds)); } else { Tcl_DStringAppendElement(dsPtr, inet_ntoa(peername.sin_addr)); } - sprintf(buf, "%d", ntohs(peername.sin_port)); + TclFormatInt(buf, ntohs(peername.sin_port)); Tcl_DStringAppendElement(dsPtr, buf); if (len == 0) { Tcl_DStringEndSublist(dsPtr); @@ -1729,14 +1809,18 @@ TcpGetOptionProc(instanceData, interp, optionName, dsPtr) Tcl_DStringStartSublist(dsPtr); } Tcl_DStringAppendElement(dsPtr, inet_ntoa(sockname.sin_addr)); - hostEntPtr = gethostbyaddr((char *) &(sockname.sin_addr), + hostEntPtr = gethostbyaddr( /* INTL: Native. */ + (char *) &sockname.sin_addr, sizeof(sockname.sin_addr), AF_INET); if (hostEntPtr != (struct hostent *) NULL) { - Tcl_DStringAppendElement(dsPtr, hostEntPtr->h_name); + Tcl_DString ds; + + Tcl_ExternalToUtfDString(NULL, hostEntPtr->h_name, -1, &ds); + Tcl_DStringAppendElement(dsPtr, Tcl_DStringValue(&ds)); } else { Tcl_DStringAppendElement(dsPtr, inet_ntoa(sockname.sin_addr)); } - sprintf(buf, "%d", ntohs(sockname.sin_port)); + TclFormatInt(buf, ntohs(sockname.sin_port)); Tcl_DStringAppendElement(dsPtr, buf); if (len == 0) { Tcl_DStringEndSublist(dsPtr); @@ -1808,7 +1892,7 @@ TcpWatchProc(instanceData, mask) * * TcpGetHandleProc -- * - * Called from Tcl_GetChannelFile to retrieve OS handles from inside + * Called from Tcl_GetChannelHandle to retrieve OS handles from inside * a TCP socket based channel. * * Results: @@ -1843,8 +1927,8 @@ TcpGetHandleProc(instanceData, direction, handlePtr) * and initializes the TcpState structure. * * Results: - * Returns a new TcpState, or NULL with an error in interp->result, - * if interp is not NULL. + * Returns a new TcpState, or NULL with an error in the interp's + * result, if interp is not NULL. * * Side effects: * Opens a socket. @@ -1983,7 +2067,7 @@ bindError: statePtr->flags = TCP_ASYNC_CONNECT; } statePtr->fd = sock; - + return statePtr; addressError: @@ -2029,9 +2113,17 @@ CreateSocketAddress(sockaddrPtr, host, port) if (host == NULL) { addr.s_addr = INADDR_ANY; } else { - addr.s_addr = inet_addr(host); + Tcl_DString ds; + CONST char *native; + + if (host == NULL) { + native = NULL; + } else { + native = Tcl_UtfToExternalDString(NULL, host, -1, &ds); + } + addr.s_addr = inet_addr(native); /* INTL: Native. */ if (addr.s_addr == -1) { - hostent = gethostbyname(host); + hostent = gethostbyname(native); /* INTL: Native. */ if (hostent != NULL) { memcpy((VOID *) &addr, (VOID *) hostent->h_addr_list[0], @@ -2044,9 +2136,15 @@ CreateSocketAddress(sockaddrPtr, host, port) errno = ENXIO; #endif #endif + if (native != NULL) { + Tcl_DStringFree(&ds); + } return 0; /* error */ } } + if (native != NULL) { + Tcl_DStringFree(&ds); + } } /* @@ -2089,7 +2187,7 @@ Tcl_OpenTcpClient(interp, port, host, myaddr, myport, async) * we do a blocking connect. */ { TcpState *statePtr; - char channelName[20]; + char channelName[16 + TCL_INTEGER_SPACE]; /* * Create a new client socket and wrap it in a channel. @@ -2136,7 +2234,7 @@ Tcl_MakeTcpClientChannel(sock) ClientData sock; /* The socket to wrap up into a channel. */ { TcpState *statePtr; - char channelName[20]; + char channelName[16 + TCL_INTEGER_SPACE]; statePtr = (TcpState *) ckalloc((unsigned) sizeof(TcpState)); statePtr->fd = (int) sock; @@ -2164,7 +2262,7 @@ Tcl_MakeTcpClientChannel(sock) * * Results: * The channel or NULL if failed. If an error occurred, an - * error message is left in interp->result if interp is + * error message is left in the interp's result if interp is * not NULL. * * Side effects: @@ -2184,7 +2282,7 @@ Tcl_OpenTcpServer(interp, port, myHost, acceptProc, acceptProcData) ClientData acceptProcData; /* Data for the callback. */ { TcpState *statePtr; - char channelName[20]; + char channelName[16 + TCL_INTEGER_SPACE]; /* * Create a new client socket and wrap it in a channel. @@ -2238,12 +2336,12 @@ TcpAccept(data, mask) TcpState *newSockState; /* State for new socket. */ struct sockaddr_in addr; /* The remote address */ int len; /* For accept interface */ - char channelName[20]; + char channelName[16 + TCL_INTEGER_SPACE]; sockState = (TcpState *) data; len = sizeof(struct sockaddr_in); - newsock = accept(sockState->fd, (struct sockaddr *)&addr, &len); + newsock = accept(sockState->fd, (struct sockaddr *) &addr, &len); if (newsock < 0) { return; } @@ -2259,18 +2357,18 @@ TcpAccept(data, mask) newSockState->flags = 0; newSockState->fd = newsock; - newSockState->acceptProc = (Tcl_TcpAcceptProc *) NULL; - newSockState->acceptProcData = (ClientData) NULL; + newSockState->acceptProc = NULL; + newSockState->acceptProcData = NULL; sprintf(channelName, "sock%d", newsock); newSockState->channel = Tcl_CreateChannel(&tcpChannelType, channelName, (ClientData) newSockState, (TCL_READABLE | TCL_WRITABLE)); - Tcl_SetChannelOption((Tcl_Interp *) NULL, newSockState->channel, - "-translation", "auto crlf"); + Tcl_SetChannelOption(NULL, newSockState->channel, "-translation", + "auto crlf"); - if (sockState->acceptProc != (Tcl_TcpAcceptProc *) NULL) { - (sockState->acceptProc) (sockState->acceptProcData, + if (sockState->acceptProc != NULL) { + (*sockState->acceptProc)(sockState->acceptProcData, newSockState->channel, inet_ntoa(addr.sin_addr), ntohs(addr.sin_port)); } @@ -2279,7 +2377,7 @@ TcpAccept(data, mask) /* *---------------------------------------------------------------------- * - * TclGetDefaultStdChannel -- + * TclpGetDefaultStdChannel -- * * Creates channels for standard input, standard output or standard * error output if they do not already exist. @@ -2295,7 +2393,7 @@ TcpAccept(data, mask) */ Tcl_Channel -TclGetDefaultStdChannel(type) +TclpGetDefaultStdChannel(type) int type; /* One of TCL_STDIN, TCL_STDOUT, TCL_STDERR. */ { Tcl_Channel channel = NULL; @@ -2364,7 +2462,7 @@ TclGetDefaultStdChannel(type) * it is open for the requested mode, then the output parameter * filePtr is set to a FILE * for the underlying file. On error, the * filePtr is not set, TCL_ERROR is returned and an error message is - * left in interp->result. + * left in the interp's result. * * Side effects: * May invoke fdopen to create the FILE * for the requested file. @@ -2413,7 +2511,11 @@ Tcl_GetOpenFile(interp, string, forWriting, checkUsage, filePtr) */ chanTypePtr = Tcl_GetChannelType(chan); - if ((chanTypePtr == &fileChannelType) || (chanTypePtr == &tcpChannelType) + if ((chanTypePtr == &fileChannelType) +#ifdef SUPPORTS_TTY + || (chanTypePtr == &ttyChannelType) +#endif /* SUPPORTS_TTY */ + || (chanTypePtr == &tcpChannelType) || (strcmp(chanTypePtr->typeName, "pipe") == 0)) { if (Tcl_GetChannelHandle(chan, (forWriting ? TCL_WRITABLE : TCL_READABLE), @@ -2481,7 +2583,7 @@ TclUnixWaitForFile(fd, mask, timeout) Tcl_Time abortTime, now; struct timeval blockTime, *timeoutPtr; int index, bit, numFound, result = 0; - static fd_mask readyMasks[3*MASK_SIZE]; + fd_mask readyMasks[3*MASK_SIZE]; /* This array reflects the readable/writable * conditions that were found to exist by the * last call to select. */ diff --git a/unix/tclUnixEvent.c b/unix/tclUnixEvent.c index e99e899..00371b5 100644 --- a/unix/tclUnixEvent.c +++ b/unix/tclUnixEvent.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. * - * RCS: @(#) $Id: tclUnixEvent.c,v 1.2 1998/09/14 18:40:17 stanton Exp $ + * RCS: @(#) $Id: tclUnixEvent.c,v 1.3 1999/04/16 00:48:04 stanton Exp $ */ #include "tclInt.h" @@ -34,7 +34,7 @@ void Tcl_Sleep(ms) int ms; /* Number of milliseconds to sleep. */ { - static struct timeval delay; + struct timeval delay; Tcl_Time before, after; /* diff --git a/unix/tclUnixFCmd.c b/unix/tclUnixFCmd.c index 14529d8..c8b35eb 100644 --- a/unix/tclUnixFCmd.c +++ b/unix/tclUnixFCmd.c @@ -5,12 +5,12 @@ * subcommands of the "file" command. All filename arguments should * already be translated to native format. * - * Copyright (c) 1996-1997 Sun Microsystems, Inc. + * Copyright (c) 1996-1998 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclUnixFCmd.c,v 1.3 1998/09/14 18:40:17 stanton Exp $ + * RCS: @(#) $Id: tclUnixFCmd.c,v 1.4 1999/04/16 00:48:04 stanton Exp $ * * Portions of this code were derived from NetBSD source code which has * the following copyright notice: @@ -51,6 +51,11 @@ #include "tclPort.h" #include <utime.h> #include <grp.h> +#ifndef HAVE_ST_BLKSIZE +#ifndef NO_FSTATFS +#include <sys/statfs.h> +#endif +#endif /* * The following constants specify the type of callback when @@ -66,30 +71,31 @@ */ static int GetGroupAttribute _ANSI_ARGS_((Tcl_Interp *interp, - int objIndex, char *fileName, + int objIndex, CONST char *fileName, Tcl_Obj **attributePtrPtr)); static int GetOwnerAttribute _ANSI_ARGS_((Tcl_Interp *interp, - int objIndex, char *fileName, + int objIndex, CONST char *fileName, Tcl_Obj **attributePtrPtr)); static int GetPermissionsAttribute _ANSI_ARGS_(( - Tcl_Interp *interp, int objIndex, char *fileName, - Tcl_Obj **attributePtrPtr)); + Tcl_Interp *interp, int objIndex, + CONST char *fileName, Tcl_Obj **attributePtrPtr)); static int SetGroupAttribute _ANSI_ARGS_((Tcl_Interp *interp, - int objIndex, char *fileName, + int objIndex, CONST char *fileName, Tcl_Obj *attributePtr)); static int SetOwnerAttribute _ANSI_ARGS_((Tcl_Interp *interp, - int objIndex, char *fileName, + int objIndex, CONST char *fileName, Tcl_Obj *attributePtr)); static int SetPermissionsAttribute _ANSI_ARGS_(( - Tcl_Interp *interp, int objIndex, char *fileName, - Tcl_Obj *attributePtr)); + Tcl_Interp *interp, int objIndex, + CONST 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)); +typedef int (TraversalProc) _ANSI_ARGS_((Tcl_DString *srcPtr, + Tcl_DString *dstPtr, CONST struct stat *statBufPtr, int type, + Tcl_DString *errorPtr)); /* * Constants and variables necessary for file attributes subcommand. @@ -101,36 +107,50 @@ enum { UNIX_PERMISSIONS_ATTRIBUTE }; -char *tclpFileAttrStrings[] = {"-group", "-owner", "-permissions", - (char *) NULL}; +char *tclpFileAttrStrings[] = { + "-group", + "-owner", + "-permissions", + (char *) NULL +}; + CONST TclFileAttrProcs tclpFileAttrProcs[] = { - {GetGroupAttribute, SetGroupAttribute}, - {GetOwnerAttribute, SetOwnerAttribute}, - {GetPermissionsAttribute, SetPermissionsAttribute}}; + {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 CopyFile _ANSI_ARGS_((CONST char *src, + CONST char *dst, CONST struct stat *statBufPtr)); +static int CopyFileAtts _ANSI_ARGS_((CONST char *src, + CONST char *dst, CONST struct stat *statBufPtr)); +static int DoCopyFile _ANSI_ARGS_((Tcl_DString *srcPtr, + Tcl_DString *dstPtr)); +static int DoCreateDirectory _ANSI_ARGS_((Tcl_DString *pathPtr)); +static int DoDeleteFile _ANSI_ARGS_((Tcl_DString *pathPtr)); +static int DoRemoveDirectory _ANSI_ARGS_((Tcl_DString *pathPtr, + int recursive, Tcl_DString *errorPtr)); +static int DoRenameFile _ANSI_ARGS_((CONST char *src, + CONST char *dst)); +static int TraversalCopy _ANSI_ARGS_((Tcl_DString *srcPtr, + Tcl_DString *dstPtr, CONST struct stat *statBufPtr, + int type, Tcl_DString *errorPtr)); +static int TraversalDelete _ANSI_ARGS_((Tcl_DString *srcPtr, + Tcl_DString *dstPtr, CONST struct stat *statBufPtr, + int type, Tcl_DString *errorPtr)); static int TraverseUnixTree _ANSI_ARGS_(( TraversalProc *traversalProc, - Tcl_DString *sourcePath, Tcl_DString *destPath, + Tcl_DString *sourcePtr, Tcl_DString *destPtr, Tcl_DString *errorPtr)); /* *--------------------------------------------------------------------------- * - * TclpRenameFile -- + * TclpRenameFile, DoRenameFile -- * * Changes the name of an existing file or directory, from src to dst. * If src and dst refer to the same file or directory, does nothing @@ -164,22 +184,53 @@ static int TraverseUnixTree _ANSI_ARGS_(( int TclpRenameFile(src, dst) - char *src; /* Pathname of file or dir to be renamed. */ - char *dst; /* New pathname of file or directory. */ + CONST char *src; /* Pathname of file or dir to be renamed + * (UTF-8). */ + CONST char *dst; /* New pathname of file or directory + * (UTF-8). */ { - if (rename(src, dst) == 0) { + int result; + Tcl_DString srcString, dstString; + + Tcl_UtfToExternalDString(NULL, src, -1, &srcString); + Tcl_UtfToExternalDString(NULL, dst, -1, &dstString); + result = DoRenameFile(Tcl_DStringValue(&srcString), + Tcl_DStringValue(&dstString)); + Tcl_DStringFree(&srcString); + Tcl_DStringFree(&dstString); + return result; +} + +static int +DoRenameFile(src, dst) + CONST char *src; /* Pathname of file or dir to be renamed + * (native). */ + CONST char *dst; /* New pathname of file or directory + * (native). */ +{ + if (rename(src, dst) == 0) { /* INTL: Native. */ return TCL_OK; } if (errno == ENOTEMPTY) { errno = EEXIST; } -#ifdef sparc + /* + * IRIX returns EIO when you attept to move a directory into + * itself. We just map EIO to EINVAL get the right message on SGI. + * Most platforms don't return EIO except in really strange cases. + */ + + if (errno == EIO) { + errno = EINVAL; + } + +#ifndef NO_REALPATH /* * SunOS 4.1.4 reports overwriting a non-empty directory with a * directory as EINVAL instead of EEXIST (first rule out the correct * EINVAL result code for moving a directory into itself). Must be - * conditionally compiled because realpath() is only defined on SunOS. + * conditionally compiled because realpath() not defined on all systems. */ if (errno == EINVAL) { @@ -187,12 +238,16 @@ TclpRenameFile(src, dst) DIR *dirPtr; struct dirent *dirEntPtr; - if ((realpath(src, srcPath) != NULL) - && (realpath(dst, dstPath) != NULL) + if ((realpath((char *) src, srcPath) != NULL) /* INTL: Native. */ + && (realpath((char *) dst, dstPath) != NULL) /* INTL: Native. */ && (strncmp(srcPath, dstPath, strlen(srcPath)) != 0)) { - dirPtr = opendir(dst); + dirPtr = opendir(dst); /* INTL: Native. */ if (dirPtr != NULL) { - while ((dirEntPtr = readdir(dirPtr)) != NULL) { + while (1) { + dirEntPtr = readdir(dirPtr); /* INTL: Native. */ + if (dirEntPtr == NULL) { + break; + } if ((strcmp(dirEntPtr->d_name, ".") != 0) && (strcmp(dirEntPtr->d_name, "..") != 0)) { errno = EEXIST; @@ -205,7 +260,7 @@ TclpRenameFile(src, dst) } errno = EINVAL; } -#endif /* sparc */ +#endif /* !NO_REALPATH */ if (strcmp(src, "/") == 0) { /* @@ -230,7 +285,7 @@ TclpRenameFile(src, dst) /* *--------------------------------------------------------------------------- * - * TclpCopyFile -- + * TclpCopyFile, DoCopyFile -- * * Copy a single file (not a directory). If dst already exists and * is not a directory, it is removed. @@ -256,18 +311,36 @@ TclpRenameFile(src, dst) int TclpCopyFile(src, dst) - char *src; /* Pathname of file to be copied. */ - char *dst; /* Pathname of file to copy to. */ + CONST char *src; /* Pathname of file to be copied (UTF-8). */ + CONST char *dst; /* Pathname of file to copy to (UTF-8). */ +{ + int result; + Tcl_DString srcString, dstString; + + Tcl_UtfToExternalDString(NULL, src, -1, &srcString); + Tcl_UtfToExternalDString(NULL, dst, -1, &dstString); + result = DoCopyFile(&srcString, &dstString); + Tcl_DStringFree(&srcString); + Tcl_DStringFree(&dstString); + return result; +} + +static int +DoCopyFile(srcPtr, dstPtr) + Tcl_DString *srcPtr; /* Pathname of file to be copied (native). */ + Tcl_DString *dstPtr; /* Pathname of file to copy to (native). */ { struct stat srcStatBuf, dstStatBuf; - char link[MAXPATHLEN]; - int length; + CONST char *src, *dst; + + src = Tcl_DStringValue(srcPtr); + dst = Tcl_DStringValue(dstPtr); /* * Have to do a stat() to determine the filetype. */ - if (lstat(src, &srcStatBuf) != 0) { + if (lstat(src, &srcStatBuf) != 0) { /* INTL: Native. */ return TCL_ERROR; } if (S_ISDIR(srcStatBuf.st_mode)) { @@ -280,47 +353,51 @@ TclpCopyFile(src, dst) * exists, so we remove it first */ - if (lstat(dst, &dstStatBuf) == 0) { + if (lstat(dst, &dstStatBuf) == 0) { /* INTL: Native. */ if (S_ISDIR(dstStatBuf.st_mode)) { errno = EISDIR; return TCL_ERROR; } } - if (unlink(dst) != 0) { + if (unlink(dst) != 0) { /* INTL: Native. */ if (errno != ENOENT) { return TCL_ERROR; } } switch ((int) (srcStatBuf.st_mode & S_IFMT)) { - case S_IFLNK: - length = readlink(src, link, sizeof(link)); + case S_IFLNK: { + char link[MAXPATHLEN]; + int length; + + length = readlink(src, link, sizeof(link)); /* INTL: Native. */ if (length == -1) { return TCL_ERROR; } link[length] = '\0'; - if (symlink(link, dst) < 0) { + if (symlink(link, dst) < 0) { /* INTL: Native. */ return TCL_ERROR; } break; - + } case S_IFBLK: - case S_IFCHR: - if (mknod(dst, srcStatBuf.st_mode, srcStatBuf.st_rdev) < 0) { + case S_IFCHR: { + if (mknod(dst, srcStatBuf.st_mode, /* INTL: Native. */ + srcStatBuf.st_rdev) < 0) { return TCL_ERROR; } return CopyFileAtts(src, dst, &srcStatBuf); - - case S_IFIFO: - if (mkfifo(dst, srcStatBuf.st_mode) < 0) { + } + case S_IFIFO: { + if (mkfifo(dst, srcStatBuf.st_mode) < 0) { /* INTL: Native. */ return TCL_ERROR; } return CopyFileAtts(src, dst, &srcStatBuf); - - default: + } + default: { return CopyFile(src, dst, &srcStatBuf); + } } - return TCL_OK; } @@ -342,10 +419,12 @@ TclpCopyFile(src, dst) */ 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 */ +CopyFile(src, dst, statBufPtr) + CONST char *src; /* Pathname of file to copy (native). */ + CONST char *dst; /* Pathname of file to create/overwrite + * (native). */ + CONST struct stat *statBufPtr; + /* Used to determine mode and blocksize. */ { int srcFd; int dstFd; @@ -353,21 +432,33 @@ CopyFile(src, dst, srcStatBufPtr) char *buffer; /* Data buffer for copy */ size_t nread; - if ((srcFd = open(src, O_RDONLY, 0)) < 0) { + if ((srcFd = open(src, O_RDONLY, 0)) < 0) { /* INTL: Native. */ return TCL_ERROR; } - dstFd = open(dst, O_CREAT | O_TRUNC | O_WRONLY, srcStatBufPtr->st_mode); + dstFd = open(dst, O_CREAT | O_TRUNC | O_WRONLY, /* INTL: Native. */ + statBufPtr->st_mode); if (dstFd < 0) { close(srcFd); return TCL_ERROR; } -#if HAVE_ST_BLKSIZE - blockSize = srcStatBufPtr->st_blksize; +#ifdef HAVE_ST_BLKSIZE + blockSize = statBufPtr->st_blksize; #else +#ifndef NO_FSTATFS + { + struct statfs fs; + if (fstatfs(srcFd, &fs, sizeof(fs), 0) == 0) { + blockSize = fs.f_bsize; + } else { + blockSize = 4096; + } + } +#else blockSize = 4096; #endif +#endif buffer = ckalloc(blockSize); while (1) { @@ -384,17 +475,17 @@ CopyFile(src, dst, srcStatBufPtr) ckfree(buffer); close(srcFd); if ((close(dstFd) != 0) || (nread == -1)) { - unlink(dst); + unlink(dst); /* INTL: Native. */ return TCL_ERROR; } - if (CopyFileAtts(src, dst, srcStatBufPtr) == TCL_ERROR) { + if (CopyFileAtts(src, dst, statBufPtr) == TCL_ERROR) { /* * The copy succeeded, but setting the permissions failed, so be in * a consistent state, we remove the file that was created by the * copy. */ - unlink(dst); + unlink(dst); /* INTL: Native. */ return TCL_ERROR; } return TCL_OK; @@ -403,7 +494,7 @@ CopyFile(src, dst, srcStatBufPtr) /* *--------------------------------------------------------------------------- * - * TclpDeleteFile -- + * TclpDeleteFile, DoDeleteFile -- * * Removes a single file (not a directory). * @@ -424,9 +515,25 @@ CopyFile(src, dst, srcStatBufPtr) int TclpDeleteFile(path) - char *path; /* Pathname of file to be removed. */ + CONST char *path; /* Pathname of file to be removed (UTF-8). */ { - if (unlink(path) != 0) { + int result; + Tcl_DString pathString; + + Tcl_UtfToExternalDString(NULL, path, -1, &pathString); + result = DoDeleteFile(&pathString); + Tcl_DStringFree(&pathString); + return result; +} + +static int +DoDeleteFile(pathPtr) + Tcl_DString *pathPtr; /* Pathname of file to be removed (native). */ +{ + CONST char *path; + + path = Tcl_DStringValue(pathPtr); + if (unlink(path) != 0) { /* INTL: Native. */ return TCL_ERROR; } return TCL_OK; @@ -435,7 +542,7 @@ TclpDeleteFile(path) /* *--------------------------------------------------------------------------- * - * TclpCreateDirectory -- + * TclpCreateDirectory, DoCreateDirectory -- * * Creates the specified directory. All parent directories of the * specified directory must already exist. The directory is @@ -460,9 +567,25 @@ TclpDeleteFile(path) int TclpCreateDirectory(path) - char *path; /* Pathname of directory to create. */ + CONST char *path; /* Pathname of directory to create (UTF-8). */ +{ + int result; + Tcl_DString pathString; + + Tcl_UtfToExternalDString(NULL, path, -1, &pathString); + result = DoCreateDirectory(&pathString); + Tcl_DStringFree(&pathString); + return result; +} + +static int +DoCreateDirectory(pathPtr) + Tcl_DString *pathPtr; /* Pathname of directory to create (native). */ { mode_t mode; + CONST char *path; + + path = Tcl_DStringValue(pathPtr); mode = umask(0); umask(mode); @@ -470,10 +593,10 @@ TclpCreateDirectory(path) /* * umask return value is actually the inverse of the permissions. */ - - mode = (0777 & ~mode); - if (mkdir(path, mode | S_IRUSR | S_IWUSR | S_IXUSR) != 0) { + mode = (0777 & ~mode) | S_IRUSR | S_IWUSR | S_IXUSR; + + if (mkdir(path, mode) != 0) { /* INTL: Native. */ return TCL_ERROR; } return TCL_OK; @@ -507,30 +630,30 @@ TclpCreateDirectory(path) 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. */ + CONST char *src; /* Pathname of directory to be copied + * (UTF-8). */ + CONST char *dst; /* Pathname of target directory (UTF-8). */ + Tcl_DString *errorPtr; /* If non-NULL, uninitialized or free + * DString filled with UTF-8 name of file + * causing error. */ { + Tcl_DString srcString, dstString; int result; - Tcl_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); + + Tcl_UtfToExternalDString(NULL, src, -1, &srcString); + Tcl_UtfToExternalDString(NULL, dst, -1, &dstString); + + result = TraverseUnixTree(TraversalCopy, &srcString, &dstString, errorPtr); + + Tcl_DStringFree(&srcString); + Tcl_DStringFree(&dstString); return result; } /* *--------------------------------------------------------------------------- * - * TclpRemoveDirectory -- + * TclpRemoveDirectory, DoRemoveDirectory -- * * Removes directory (and its contents, if the recursive flag is set). * @@ -555,17 +678,40 @@ TclpCopyDirectory(src, dst, errorPtr) int TclpRemoveDirectory(path, recursive, errorPtr) - char *path; /* Pathname of directory to be removed. */ + CONST char *path; /* Pathname of directory to be removed + * (UTF-8). */ int recursive; /* If non-zero, removes directories that * are nonempty. Otherwise, will only remove * empty directories. */ - Tcl_DString *errorPtr; /* If non-NULL, initialized DString for - * error reporting. */ + Tcl_DString *errorPtr; /* If non-NULL, uninitialized or free + * DString filled with UTF-8 name of file + * causing error. */ { int result; - Tcl_DString buffer; + Tcl_DString pathString; + + Tcl_UtfToExternalDString(NULL, path, -1, &pathString); + result = DoRemoveDirectory(&pathString, recursive, errorPtr); + Tcl_DStringFree(&pathString); - if (rmdir(path) == 0) { + return result; +} + +static int +DoRemoveDirectory(pathPtr, recursive, errorPtr) + Tcl_DString *pathPtr; /* Pathname of directory to be removed + * (native). */ + int recursive; /* If non-zero, removes directories that + * are nonempty. Otherwise, will only remove + * empty directories. */ + Tcl_DString *errorPtr; /* If non-NULL, uninitialized or free + * DString filled with UTF-8 name of file + * causing error. */ +{ + CONST char *path; + + path = Tcl_DStringValue(pathPtr); + if (rmdir(path) == 0) { /* INTL: Native. */ return TCL_OK; } if (errno == ENOTEMPTY) { @@ -573,7 +719,7 @@ TclpRemoveDirectory(path, recursive, errorPtr) } if ((errno != EEXIST) || (recursive == 0)) { if (errorPtr != NULL) { - Tcl_DStringAppend(errorPtr, path, -1); + Tcl_ExternalToUtfDString(NULL, path, -1, errorPtr); } return TCL_ERROR; } @@ -583,11 +729,7 @@ TclpRemoveDirectory(path, recursive, errorPtr) * 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; + return TraverseUnixTree(TraversalDelete, pathPtr, NULL, errorPtr); } /* @@ -617,43 +759,39 @@ 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. */ + * traversed (native). */ 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. */ + * parallel with source directory (native). */ + Tcl_DString *errorPtr; /* If non-NULL, uninitialized or free + * DString filled with UTF-8 name of file + * causing error. */ { - struct stat statbuf; - char *source, *target, *errfile; + struct stat statBuf; + CONST char *source, *errfile; int result, sourceLen; - int targetLen = 0; /* Initialization needed only to prevent - * warning in gcc. */ - struct dirent *dirp; - DIR *dp; + int targetLen; + struct dirent *dirEntPtr; + DIR *dirPtr; + errfile = NULL; result = TCL_OK; - source = Tcl_DStringValue(sourcePtr); - if (targetPtr != NULL) { - target = Tcl_DStringValue(targetPtr); - } else { - target = NULL; - } + targetLen = 0; /* lint. */ - errfile = NULL; - if (lstat(source, &statbuf) != 0) { + source = Tcl_DStringValue(sourcePtr); + if (lstat(source, &statBuf) != 0) { /* INTL: Native. */ errfile = source; goto end; } - if (!S_ISDIR(statbuf.st_mode)) { + if (!S_ISDIR(statBuf.st_mode)) { /* * Process the regular file */ - return (*traverseProc)(source, target, &statbuf, DOTREE_F, errorPtr); + return (*traverseProc)(sourcePtr, targetPtr, &statBuf, DOTREE_F, + errorPtr); } - - dp = opendir(source); - if (dp == NULL) { + dirPtr = opendir(source); /* INTL: Native. */ + if (dirPtr == NULL) { /* * Can't read directory */ @@ -661,25 +799,24 @@ TraverseUnixTree(traverseProc, sourcePtr, targetPtr, errorPtr) errfile = source; goto end; } - result = (*traverseProc)(source, target, &statbuf, DOTREE_PRED, errorPtr); + result = (*traverseProc)(sourcePtr, targetPtr, &statBuf, DOTREE_PRED, + errorPtr); if (result != TCL_OK) { - closedir(dp); + closedir(dirPtr); 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)) { + while ((dirEntPtr = readdir(dirPtr)) != NULL) { /* INTL: Native. */ + if ((strcmp(dirEntPtr->d_name, ".") == 0) + || (strcmp(dirEntPtr->d_name, "..") == 0)) { continue; } @@ -687,9 +824,9 @@ TraverseUnixTree(traverseProc, sourcePtr, targetPtr, errorPtr) * Append name after slash, and recurse on the file. */ - Tcl_DStringAppend(sourcePtr, dirp->d_name, -1); + Tcl_DStringAppend(sourcePtr, dirEntPtr->d_name, -1); if (targetPtr != NULL) { - Tcl_DStringAppend(targetPtr, dirp->d_name, -1); + Tcl_DStringAppend(targetPtr, dirEntPtr->d_name, -1); } result = TraverseUnixTree(traverseProc, sourcePtr, targetPtr, errorPtr); @@ -706,17 +843,15 @@ TraverseUnixTree(traverseProc, sourcePtr, targetPtr, errorPtr) Tcl_DStringSetLength(targetPtr, targetLen); } } - closedir(dp); + closedir(dirPtr); /* * 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) { @@ -725,13 +860,13 @@ TraverseUnixTree(traverseProc, sourcePtr, targetPtr, errorPtr) * files in that directory. */ - result = (*traverseProc)(source, target, &statbuf, DOTREE_POSTD, + result = (*traverseProc)(sourcePtr, targetPtr, &statBuf, DOTREE_POSTD, errorPtr); } end: if (errfile != NULL) { if (errorPtr != NULL) { - Tcl_DStringAppend(errorPtr, errfile, -1); + Tcl_ExternalToUtfDString(NULL, errfile, -1, errorPtr); } result = TCL_ERROR; } @@ -758,29 +893,32 @@ TraverseUnixTree(traverseProc, sourcePtr, targetPtr, errorPtr) */ 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. */ +TraversalCopy(srcPtr, dstPtr, statBufPtr, type, errorPtr) + Tcl_DString *srcPtr; /* Source pathname to copy (native). */ + Tcl_DString *dstPtr; /* Destination pathname of copy (native). */ + CONST struct stat *statBufPtr; + /* Stat info for file specified by srcPtr. */ int type; /* Reason for call - see TraverseUnixTree(). */ - Tcl_DString *errorPtr; /* If non-NULL, initialized DString for - * error return. */ + Tcl_DString *errorPtr; /* If non-NULL, uninitialized or free + * DString filled with UTF-8 name of file + * causing error. */ { switch (type) { case DOTREE_F: - if (TclpCopyFile(src, dst) == TCL_OK) { + if (DoCopyFile(srcPtr, dstPtr) == TCL_OK) { return TCL_OK; } break; case DOTREE_PRED: - if (TclpCreateDirectory(dst) == TCL_OK) { + if (DoCreateDirectory(dstPtr) == TCL_OK) { return TCL_OK; } break; case DOTREE_POSTD: - if (CopyFileAtts(src, dst, sbPtr) == TCL_OK) { + if (CopyFileAtts(Tcl_DStringValue(srcPtr), + Tcl_DStringValue(dstPtr), statBufPtr) == TCL_OK) { return TCL_OK; } break; @@ -788,12 +926,13 @@ TraversalCopy(src, dst, sbPtr, type, errorPtr) } /* - * There shouldn't be a problem with src, because we already - * checked it to get here. + * There shouldn't be a problem with src, because we already checked it + * to get here. */ if (errorPtr != NULL) { - Tcl_DStringAppend(errorPtr, dst, -1); + Tcl_ExternalToUtfDString(NULL, Tcl_DStringValue(dstPtr), + Tcl_DStringLength(dstPtr), errorPtr); } return TCL_ERROR; } @@ -818,62 +957,65 @@ TraversalCopy(src, dst, sbPtr, type, errorPtr) */ 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. */ +TraversalDelete(srcPtr, ignore, statBufPtr, type, errorPtr) + Tcl_DString *srcPtr; /* Source pathname (native). */ + Tcl_DString *ignore; /* Destination pathname (not used). */ + CONST struct stat *statBufPtr; + /* Stat info for file specified by srcPtr. */ int type; /* Reason for call - see TraverseUnixTree(). */ - Tcl_DString *errorPtr; /* If non-NULL, initialized DString for - * error return. */ + Tcl_DString *errorPtr; /* If non-NULL, uninitialized or free + * DString filled with UTF-8 name of file + * causing error. */ { switch (type) { - case DOTREE_F: - if (unlink(src) == 0) { + case DOTREE_F: { + if (DoDeleteFile(srcPtr) == 0) { return TCL_OK; } break; - - case DOTREE_PRED: + } + case DOTREE_PRED: { return TCL_OK; - - case DOTREE_POSTD: - if (rmdir(src) == 0) { + } + case DOTREE_POSTD: { + if (DoRemoveDirectory(srcPtr, 0, NULL) == 0) { return TCL_OK; } break; - + } } - if (errorPtr != NULL) { - Tcl_DStringAppend(errorPtr, src, -1); + Tcl_ExternalToUtfDString(NULL, Tcl_DStringValue(srcPtr), + Tcl_DStringLength(srcPtr), errorPtr); } return TCL_ERROR; } /* - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- * - * CopyFileAtts + * CopyFileAtts -- * - * Copy the file attributes such as owner, group, permissions, and - * modification date from one file to another. + * Copy the file attributes such as owner, group, permissions, + * and modification date from one file to another. * * Results: - * Standard Tcl result. + * 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. - * - *---------------------------------------------------------------------- + * 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 */ + CONST char *src; /* Path name of source file (native). */ + CONST char *dst; /* Path name of target file (native). */ + CONST struct stat *statBufPtr; + /* Stat info for source file */ { struct utimbuf tval; mode_t newMode; @@ -890,9 +1032,9 @@ CopyFileAtts(src, dst, statBufPtr) * It would require another lstat(), or getuid(). */ - if (chmod(dst, newMode)) { + if (chmod(dst, newMode)) { /* INTL: Native. */ newMode &= ~(S_ISUID | S_ISGID); - if (chmod(dst, newMode)) { + if (chmod(dst, newMode)) { /* INTL: Native. */ return TCL_ERROR; } } @@ -900,11 +1042,12 @@ CopyFileAtts(src, dst, statBufPtr) tval.actime = statBufPtr->st_atime; tval.modtime = statBufPtr->st_mtime; - if (utime(dst, &tval)) { + if (utime(dst, &tval)) { /* INTL: Native. */ return TCL_ERROR; } return TCL_OK; } + /* *---------------------------------------------------------------------- @@ -927,24 +1070,31 @@ 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. */ + CONST char *fileName; /* The name of the file (UTF-8). */ Tcl_Obj **attributePtrPtr; /* A pointer to return the object with. */ { struct stat statBuf; struct group *groupPtr; + int result; - if (TclStat(fileName, &statBuf) != 0) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "could not stat file \"", fileName, "\": ", + result = TclStat(fileName, &statBuf); + + if (result != 0) { + Tcl_AppendResult(interp, "could not read \"", fileName, "\": ", Tcl_PosixError(interp), (char *) NULL); return TCL_ERROR; } - groupPtr = getgrgid(statBuf.st_gid); + groupPtr = getgrgid(statBuf.st_gid); /* INTL: Native. */ if (groupPtr == NULL) { *attributePtrPtr = Tcl_NewIntObj(statBuf.st_gid); } else { - *attributePtrPtr = Tcl_NewStringObj(groupPtr->gr_name, -1); + Tcl_DString ds; + CONST char *utf; + + utf = Tcl_ExternalToUtfDString(NULL, groupPtr->gr_name, -1, &ds); + *attributePtrPtr = Tcl_NewStringObj(utf, -1); + Tcl_DStringFree(&ds); } endgrent(); return TCL_OK; @@ -971,24 +1121,31 @@ 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. */ + CONST char *fileName; /* The name of the file (UTF-8). */ Tcl_Obj **attributePtrPtr; /* A pointer to return the object with. */ { struct stat statBuf; struct passwd *pwPtr; + int result; - if (TclStat(fileName, &statBuf) != 0) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "could not stat file \"", fileName, "\": ", + result = TclStat(fileName, &statBuf); + + if (result != 0) { + Tcl_AppendResult(interp, "could not read \"", fileName, "\": ", Tcl_PosixError(interp), (char *) NULL); return TCL_ERROR; } - pwPtr = getpwuid(statBuf.st_uid); + pwPtr = getpwuid(statBuf.st_uid); /* INTL: Native. */ if (pwPtr == NULL) { *attributePtrPtr = Tcl_NewIntObj(statBuf.st_uid); } else { - *attributePtrPtr = Tcl_NewStringObj(pwPtr->pw_name, -1); + Tcl_DString ds; + CONST char *utf; + + utf = Tcl_ExternalToUtfDString(NULL, pwPtr->pw_name, -1, &ds); + *attributePtrPtr = Tcl_NewStringObj(utf, Tcl_DStringLength(&ds)); + Tcl_DStringFree(&ds); } endpwent(); return TCL_OK; @@ -1015,15 +1172,17 @@ 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. */ + CONST char *fileName; /* The name of the file (UTF-8). */ Tcl_Obj **attributePtrPtr; /* A pointer to return the object with. */ { struct stat statBuf; - char returnString[6]; + char returnString[7]; + int result; - if (TclStat(fileName, &statBuf) != 0) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "could not stat file \"", fileName, "\": ", + result = TclStat(fileName, &statBuf); + + if (result != 0) { + Tcl_AppendResult(interp, "could not read \"", fileName, "\": ", Tcl_PosixError(interp), (char *) NULL); return TCL_ERROR; } @@ -1036,155 +1195,163 @@ GetPermissionsAttribute(interp, objIndex, fileName, attributePtrPtr) } /* - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- * - * SetGroupAttribute + * SetGroupAttribute -- * - * Sets the file to the given group. + * Sets the group of the file to the specified group. * * Results: * Standard TCL result. * * Side effects: - * The group of the file is changed. + * As above. * - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- */ static int SetGroupAttribute(interp, objIndex, fileName, attributePtr) - Tcl_Interp *interp; /* The interp we are using for errors. */ + Tcl_Interp *interp; /* The interp for error reporting. */ int objIndex; /* The index of the attribute. */ - char *fileName; /* The name of the file. */ - Tcl_Obj *attributePtr; /* The attribute to set. */ + CONST char *fileName; /* The name of the file (UTF-8). */ + Tcl_Obj *attributePtr; /* New group for file. */ { - gid_t groupNumber; - long placeHolder; + long gid; + int result; + Tcl_DString ds; + CONST char *native; - if (Tcl_GetLongFromObj(interp, attributePtr, &placeHolder) != TCL_OK) { + if (Tcl_GetLongFromObj(NULL, attributePtr, &gid) != TCL_OK) { struct group *groupPtr; - char *groupString = Tcl_GetStringFromObj(attributePtr, NULL); + CONST char *string; + int length; + + string = Tcl_GetStringFromObj(attributePtr, &length); + + native = Tcl_UtfToExternalDString(NULL, string, length, &ds); + groupPtr = getgrnam(native); /* INTL: Native. */ + Tcl_DStringFree(&ds); - 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", + Tcl_AppendResult(interp, "could not set group for file \"", + fileName, "\": group \"", string, "\" does not exist", (char *) NULL); return TCL_ERROR; } - groupNumber = groupPtr->gr_gid; - } else { - groupNumber = (gid_t) placeHolder; + gid = groupPtr->gr_gid; } - if (chown(fileName, -1, groupNumber) != 0) { - endgrent(); - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "could not set group for file \"", fileName, "\": ", - Tcl_PosixError(interp), (char *) NULL); + native = Tcl_UtfToExternalDString(NULL, fileName, -1, &ds); + result = chown(native, -1, (gid_t) gid); /* INTL: Native. */ + Tcl_DStringFree(&ds); + + endgrent(); + if (result != 0) { + Tcl_AppendResult(interp, "could not set group for file \"", + fileName, "\": ", Tcl_PosixError(interp), (char *) NULL); return TCL_ERROR; } - endgrent(); return TCL_OK; } /* - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- * - * SetOwnerAttribute + * SetOwnerAttribute -- * - * Sets the file to the given owner. + * Sets the owner of the file to the specified owner. * * Results: * Standard TCL result. * * Side effects: - * The group of the file is changed. + * As above. * - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- */ static int SetOwnerAttribute(interp, objIndex, fileName, attributePtr) - Tcl_Interp *interp; /* The interp we are using for errors. */ + Tcl_Interp *interp; /* The interp for error reporting. */ int objIndex; /* The index of the attribute. */ - char *fileName; /* The name of the file. */ - Tcl_Obj *attributePtr; /* The attribute to set. */ + CONST char *fileName; /* The name of the file (UTF-8). */ + Tcl_Obj *attributePtr; /* New owner for file. */ { - uid_t userNumber; - long placeHolder; + long uid; + int result; + Tcl_DString ds; + CONST char *native; - if (Tcl_GetLongFromObj(interp, attributePtr, &placeHolder) != TCL_OK) { + if (Tcl_GetLongFromObj(NULL, attributePtr, &uid) != TCL_OK) { struct passwd *pwPtr; - char *ownerString = Tcl_GetStringFromObj(attributePtr, NULL); + CONST char *string; + int length; + + string = Tcl_GetStringFromObj(attributePtr, &length); + + native = Tcl_UtfToExternalDString(NULL, string, length, &ds); + pwPtr = getpwnam(native); /* INTL: Native. */ + Tcl_DStringFree(&ds); - 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", + Tcl_AppendResult(interp, "could not set owner for file \"", + fileName, "\": user \"", string, "\" does not exist", (char *) NULL); return TCL_ERROR; } - userNumber = pwPtr->pw_uid; - } else { - userNumber = (uid_t) placeHolder; + uid = pwPtr->pw_uid; } - if (chown(fileName, userNumber, -1) != 0) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "could not set owner for file \"", fileName, "\": ", - Tcl_PosixError(interp), (char *) NULL); + native = Tcl_UtfToExternalDString(NULL, fileName, -1, &ds); + result = chown(native, uid, -1); /* INTL: Native. */ + Tcl_DStringFree(&ds); + + if (result != 0) { + Tcl_AppendResult(interp, "could not set owner for file \"", fileName, + "\": ", Tcl_PosixError(interp), (char *) NULL); return TCL_ERROR; } - return TCL_OK; } /* - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- * * SetPermissionsAttribute * - * Sets the file to the given group. + * Sets the file to the given permission. * * Results: * Standard TCL result. * * Side effects: - * The group of the file is changed. + * The permission of the file is changed. * - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- */ static int SetPermissionsAttribute(interp, objIndex, fileName, attributePtr) Tcl_Interp *interp; /* The interp we are using for errors. */ int objIndex; /* The index of the attribute. */ - char *fileName; /* The name of the file. */ + CONST char *fileName; /* The name of the file (UTF-8). */ Tcl_Obj *attributePtr; /* The attribute to set. */ { - long modeInt; - mode_t newMode; + long mode; + int result; + CONST char *native; + Tcl_DString ds; - /* - * 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) { + if (Tcl_GetLongFromObj(interp, attributePtr, &mode) != TCL_OK) { return TCL_ERROR; } - newMode = (mode_t) modeInt; - - if (chmod(fileName, newMode) != 0) { + native = Tcl_UtfToExternalDString(NULL, fileName, -1, &ds); + result = chmod(native, (mode_t) mode); /* INTL: Native. */ + Tcl_DStringFree(&ds); + if (result != 0) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "could not set permissions for file \"", fileName, "\": ", Tcl_PosixError(interp), (char *) NULL); diff --git a/unix/tclUnixFile.c b/unix/tclUnixFile.c index ace9c3e..248079d 100644 --- a/unix/tclUnixFile.c +++ b/unix/tclUnixFile.c @@ -4,237 +4,63 @@ * This file contains wrappers around UNIX file handling functions. * These wrappers mask differences between Windows and UNIX. * - * Copyright (c) 1995 Sun Microsystems, Inc. + * Copyright (c) 1995-1998 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclUnixFile.c,v 1.5 1999/03/10 05:52:52 stanton Exp $ + * RCS: @(#) $Id: tclUnixFile.c,v 1.6 1999/04/16 00:48:05 stanton Exp $ */ #include "tclInt.h" #include "tclPort.h" -/* - * The variable below caches the name of the current working directory - * in order to avoid repeated calls to getcwd. The string is malloc-ed. - * NULL means the cache needs to be refreshed. - */ - -static char *currentDir = NULL; -static int currentDirExitHandlerSet = 0; - -/* - * The variable below is set if the exit routine for deleting the string - * containing the executable name has been registered. - */ - -static int executableNameExitHandlerSet = 0; - -extern pid_t waitpid _ANSI_ARGS_((pid_t pid, int *stat_loc, int options)); - -/* - * Static routines for this file: - */ - -static void FreeExecutableName _ANSI_ARGS_((ClientData clientData)); - -/* - *---------------------------------------------------------------------- - * - * FreeCurrentDir -- - * - * Frees the string stored in the currentDir variable. This routine - * is registered as an exit handler and will be called during shutdown. - * - * Results: - * None. - * - * Side effects: - * Frees the memory occuppied by the currentDir value. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -static void -FreeCurrentDir(clientData) - ClientData clientData; /* Not used. */ -{ - if (currentDir != (char *) NULL) { - ckfree(currentDir); - currentDir = (char *) NULL; - currentDirExitHandlerSet = 0; - } -} - -/* - *---------------------------------------------------------------------- - * - * FreeExecutableName -- - * - * Frees the string stored in the tclExecutableName variable. This - * routine is registered as an exit handler and will be called - * during shutdown. - * - * Results: - * None. - * - * Side effects: - * Frees the memory occuppied by the tclExecutableName value. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -static void -FreeExecutableName(clientData) - ClientData clientData; /* Not used. */ -{ - if (tclExecutableName != (char *) NULL) { - ckfree(tclExecutableName); - tclExecutableName = (char *) NULL; - } -} /* - *---------------------------------------------------------------------- - * - * TclChdir -- - * - * Change the current working directory. - * - * Results: - * The result is a standard Tcl result. If an error occurs and - * interp isn't NULL, an error message is left in interp->result. - * - * Side effects: - * The working directory for this application is changed. Also - * the cache maintained used by TclGetCwd is deallocated and - * set to NULL. - * - *---------------------------------------------------------------------- - */ - -int -TclChdir(interp, dirName) - Tcl_Interp *interp; /* If non NULL, used for error reporting. */ - char *dirName; /* Path to new working directory. */ -{ - if (currentDir != NULL) { - ckfree(currentDir); - currentDir = NULL; - } - if (chdir(dirName) != 0) { - if (interp != NULL) { - Tcl_AppendResult(interp, "couldn't change working directory to \"", - dirName, "\": ", Tcl_PosixError(interp), (char *) NULL); - } - return TCL_ERROR; - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclGetCwd -- - * - * Return the path name of the current working directory. - * - * Results: - * The result is the full path name of the current working - * directory, or NULL if an error occurred while figuring it out. - * The returned string is owned by the TclGetCwd routine and must - * not be freed by the caller. If an error occurs and interp - * isn't NULL, an error message is left in interp->result. - * - * Side effects: - * The path name is cached to avoid having to recompute it - * on future calls; if it is already cached, the cached - * value is returned. - * - *---------------------------------------------------------------------- - */ - -char * -TclGetCwd(interp) - Tcl_Interp *interp; /* If non NULL, used for error reporting. */ -{ - char buffer[MAXPATHLEN+1]; - - if (currentDir == NULL) { - if (!currentDirExitHandlerSet) { - currentDirExitHandlerSet = 1; - Tcl_CreateExitHandler(FreeCurrentDir, (ClientData) NULL); - } -#ifdef USEGETWD - if ((int)getwd(buffer) == (int)NULL) { - if (interp != NULL) { - Tcl_AppendResult(interp, - "error getting working directory name: ", - buffer, (char *)NULL); - } - return NULL; - } -#else - if (getcwd(buffer, MAXPATHLEN+1) == NULL) { - if (interp != NULL) { - if (errno == ERANGE) { - Tcl_SetResult(interp, - "working directory name is too long", - TCL_STATIC); - } else { - Tcl_AppendResult(interp, - "error getting working directory name: ", - Tcl_PosixError(interp), (char *) NULL); - } - } - return NULL; - } -#endif - currentDir = (char *) ckalloc((unsigned) (strlen(buffer) + 1)); - strcpy(currentDir, buffer); - } - return currentDir; -} - -/* - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- * - * Tcl_FindExecutable -- + * TclpFindExecutable -- * * This procedure computes the absolute path name of the current * application, given its argv[0] value. * * Results: - * None. + * A dirty UTF string that is the path to the executable. At this + * point we may not know the system encoding. Convert the native + * string value to UTF using the default encoding. The assumption + * is that we will still be able to parse the path given the path + * name contains ASCII string and '/' chars do not conflict with + * other UTF chars. * * Side effects: - * The variable tclExecutableName gets filled in with the file + * The variable tclNativeExecutableName gets filled in with the file * name for the application, if we figured it out. If we couldn't - * figure it out, Tcl_FindExecutable is set to NULL. + * figure it out, tclNativeExecutableName is set to NULL. * - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- */ -void -Tcl_FindExecutable(argv0) - char *argv0; /* The value of the application's argv[0]. */ +char * +TclpFindExecutable(argv0) + CONST char *argv0; /* The value of the application's argv[0] + * (native). */ { - char *name, *p, *cwd; - Tcl_DString buffer; - int length; + CONST char *name, *p; struct stat statBuf; + int length; + Tcl_DString buffer, nameString; - Tcl_DStringInit(&buffer); - if (tclExecutableName != NULL) { - ckfree(tclExecutableName); - tclExecutableName = NULL; + if (argv0 == NULL) { + return NULL; } + if (tclNativeExecutableName != NULL) { + return tclNativeExecutableName; + } + + Tcl_DStringInit(&buffer); name = argv0; - for (p = name; *p != 0; p++) { + for (p = name; *p != '\0'; p++) { if (*p == '/') { /* * The name contains a slash, so use the name directly @@ -245,7 +71,7 @@ Tcl_FindExecutable(argv0) } } - p = getenv("PATH"); + p = getenv("PATH"); /* INTL: Native. */ if (p == NULL) { /* * There's no PATH environment variable; use the default that @@ -267,8 +93,8 @@ Tcl_FindExecutable(argv0) * name. */ - while (*p != 0) { - while (isspace(UCHAR(*p))) { + while (1) { + while (isspace(UCHAR(*p))) { /* INTL: BUG */ p++; } name = p; @@ -277,19 +103,25 @@ Tcl_FindExecutable(argv0) } Tcl_DStringSetLength(&buffer, 0); if (p != name) { - Tcl_DStringAppend(&buffer, name, p-name); + Tcl_DStringAppend(&buffer, name, p - name); if (p[-1] != '/') { Tcl_DStringAppend(&buffer, "/", 1); } } - Tcl_DStringAppend(&buffer, argv0, -1); - if ((TclAccess(Tcl_DStringValue(&buffer), X_OK) == 0) - && (TclStat(Tcl_DStringValue(&buffer), &statBuf) == 0) + name = Tcl_DStringAppend(&buffer, argv0, -1); + + /* + * INTL: The following calls to access() and stat() should not be + * converted to Tclp routines because they need to operate on native + * strings directly. + */ + + if ((access(name, X_OK) == 0) /* INTL: Native. */ + && (stat(name, &statBuf) == 0) /* INTL: Native. */ && S_ISREG(statBuf.st_mode)) { - name = Tcl_DStringValue(&buffer); goto gotName; } - if (*p == 0) { + if (*p == '\0') { break; } else if (*(p+1) == 0) { p = "./"; @@ -305,8 +137,11 @@ Tcl_FindExecutable(argv0) gotName: if (name[0] == '/') { - tclExecutableName = (char *) ckalloc((unsigned) (strlen(name) + 1)); - strcpy(tclExecutableName, name); + Tcl_ExternalToUtfDString(NULL, name, -1, &nameString); + tclNativeExecutableName = (char *) + ckalloc((unsigned) (Tcl_DStringLength(&nameString) + 1)); + strcpy(tclNativeExecutableName, Tcl_DStringValue(&nameString)); + Tcl_DStringFree(&nameString); goto done; } @@ -319,79 +154,36 @@ Tcl_FindExecutable(argv0) if ((name[0] == '.') && (name[1] == '/')) { name += 2; } - cwd = TclGetCwd((Tcl_Interp *) NULL); - if (cwd == NULL) { - tclExecutableName = NULL; - goto done; - } - length = strlen(cwd); - tclExecutableName = (char *) ckalloc((unsigned) - (length + strlen(name) + 2)); - strcpy(tclExecutableName, cwd); - tclExecutableName[length] = '/'; - strcpy(tclExecutableName + length + 1, name); + Tcl_ExternalToUtfDString(NULL, name, -1, &nameString); + + Tcl_DStringFree(&buffer); + TclpGetCwd(NULL, &buffer); + + length = Tcl_DStringLength(&buffer) + Tcl_DStringLength(&nameString) + 2; + tclNativeExecutableName = (char *) ckalloc((unsigned) length); + strcpy(tclNativeExecutableName, Tcl_DStringValue(&buffer)); + tclNativeExecutableName[Tcl_DStringLength(&buffer)] = '/'; + strcpy(tclNativeExecutableName + Tcl_DStringLength(&buffer) + 1, + Tcl_DStringValue(&nameString)); + Tcl_DStringFree(&nameString); + done: Tcl_DStringFree(&buffer); - - if (!executableNameExitHandlerSet) { - executableNameExitHandlerSet = 1; - Tcl_CreateExitHandler(FreeExecutableName, (ClientData) NULL); - } -} - -/* - *---------------------------------------------------------------------- - * - * TclGetUserHome -- - * - * This function takes the passed in user name and finds the - * corresponding home directory specified in the password file. - * - * Results: - * The result is a pointer to a static string containing - * the new name. If there was an error in processing the - * user name then the return value is NULL. Otherwise the - * result is stored in bufferPtr, and the caller must call - * Tcl_DStringFree(bufferPtr) to free the result. - * - * Side effects: - * Information may be left in bufferPtr. - * - *---------------------------------------------------------------------- - */ - -char * -TclGetUserHome(name, bufferPtr) - char *name; /* User name to use to find home directory. */ - Tcl_DString *bufferPtr; /* May be used to hold result. Must not hold - * anything at the time of the call, and need - * not even be initialized. */ -{ - struct passwd *pwPtr; - - pwPtr = getpwnam(name); - if (pwPtr == NULL) { - endpwent(); - return NULL; - } - Tcl_DStringInit(bufferPtr); - Tcl_DStringAppend(bufferPtr, pwPtr->pw_dir, -1); - endpwent(); - return bufferPtr->string; + return tclNativeExecutableName; } /* *---------------------------------------------------------------------- * - * TclMatchFiles -- + * TclpMatchFiles -- * * This routine is used by the globbing code to search a * directory for all files which match a given pattern. * * Results: * If the tail argument is NULL, then the matching files are - * added to the interp->result. Otherwise, TclDoGlob is called + * added to the the interp's result. Otherwise, TclDoGlob is called * recursively for each matching subdirectory. The return value * is a standard Tcl result indicating whether an error occurred * in globbing. @@ -403,19 +195,19 @@ TclGetUserHome(name, bufferPtr) */ int -TclMatchFiles(interp, separators, dirPtr, pattern, tail) +TclpMatchFiles(interp, separators, dirPtr, pattern, tail) Tcl_Interp *interp; /* Interpreter to receive results. */ char *separators; /* Path separators to pass to TclDoGlob. */ Tcl_DString *dirPtr; /* Contains path to directory to search. */ char *pattern; /* Pattern to match against. */ - char *tail; /* Pointer to end of pattern. */ + char *tail; /* Pointer to end of pattern. Must not + * refer to a static string. */ { - char *dirName, *patternEnd = tail; - char savedChar = 0; /* Initialization needed only to prevent - * compiler warning from gcc. */ + char *native, *dirName, *patternEnd = tail; + char savedChar = 0; /* lint. */ DIR *d; + Tcl_DString ds; struct stat statBuf; - struct dirent *entryPtr; int matchHidden; int result = TCL_OK; int baseLength = Tcl_DStringLength(dirPtr); @@ -428,12 +220,14 @@ TclMatchFiles(interp, separators, dirPtr, pattern, tail) * otherwise "glob foo.c" would return "./foo.c". */ - if (dirPtr->string[0] == '\0') { + if (Tcl_DStringLength(dirPtr) == 0) { dirName = "."; } else { - dirName = dirPtr->string; + dirName = Tcl_DStringValue(dirPtr); } - if ((TclStat(dirName, &statBuf) != 0) || !S_ISDIR(statBuf.st_mode)) { + + if ((TclpStat(dirName, &statBuf) != 0) /* INTL: UTF-8. */ + || !S_ISDIR(statBuf.st_mode)) { return TCL_OK; } @@ -452,7 +246,9 @@ TclMatchFiles(interp, separators, dirPtr, pattern, tail) * Now open the directory for reading and iterate over the contents. */ - d = opendir(dirName); + native = Tcl_UtfToExternalDString(NULL, dirName, -1, &ds); + d = opendir(native); /* INTL: Native. */ + Tcl_DStringFree(&ds); if (d == NULL) { Tcl_ResetResult(interp); @@ -461,15 +257,16 @@ TclMatchFiles(interp, separators, dirPtr, pattern, tail) */ if (baseLength > 0) { - savedChar = dirPtr->string[baseLength-1]; + savedChar = (Tcl_DStringValue(dirPtr))[baseLength-1]; if (savedChar == '/') { - dirPtr->string[baseLength-1] = '\0'; + (Tcl_DStringValue(dirPtr))[baseLength-1] = '\0'; } } Tcl_AppendResult(interp, "couldn't read directory \"", - dirPtr->string, "\": ", Tcl_PosixError(interp), (char *) NULL); + Tcl_DStringValue(dirPtr), "\": ", + Tcl_PosixError(interp), (char *) NULL); if (baseLength > 0) { - dirPtr->string[baseLength-1] = savedChar; + (Tcl_DStringValue(dirPtr))[baseLength-1] = savedChar; } return TCL_ERROR; } @@ -493,7 +290,10 @@ TclMatchFiles(interp, separators, dirPtr, pattern, tail) *patternEnd = '\0'; while (1) { - entryPtr = readdir(d); + char *utf; + struct dirent *entryPtr; + + entryPtr = readdir(d); /* INTL: Native. */ if (entryPtr == NULL) { break; } @@ -514,20 +314,23 @@ TclMatchFiles(interp, separators, dirPtr, pattern, tail) * the file to the result. */ - if (Tcl_StringMatch(entryPtr->d_name, pattern)) { + utf = Tcl_ExternalToUtfDString(NULL, entryPtr->d_name, -1, &ds); + if (Tcl_StringMatch(utf, pattern) != 0) { Tcl_DStringSetLength(dirPtr, baseLength); - Tcl_DStringAppend(dirPtr, entryPtr->d_name, -1); + Tcl_DStringAppend(dirPtr, utf, -1); if (tail == NULL) { - Tcl_AppendElement(interp, dirPtr->string); - } else if ((TclStat(dirPtr->string, &statBuf) == 0) + Tcl_AppendElement(interp, Tcl_DStringValue(dirPtr)); + } else if ((TclpStat(Tcl_DStringValue(dirPtr), &statBuf) == 0) && S_ISDIR(statBuf.st_mode)) { Tcl_DStringAppend(dirPtr, "/", 1); result = TclDoGlob(interp, separators, dirPtr, tail); if (result != TCL_OK) { + Tcl_DStringFree(&ds); break; } } } + Tcl_DStringFree(&ds); } *patternEnd = savedChar; @@ -538,6 +341,50 @@ TclMatchFiles(interp, separators, dirPtr, pattern, tail) /* *--------------------------------------------------------------------------- * + * TclpGetUserHome -- + * + * This function takes the specified user name and finds their + * home directory. + * + * Results: + * The result is a pointer to a string specifying the user's home + * directory, or NULL if the user's home directory could not be + * determined. Storage for the result string is allocated in + * bufferPtr; the caller must call Tcl_DStringFree() when the result + * is no longer needed. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +char * +TclpGetUserHome(name, bufferPtr) + CONST char *name; /* User name for desired home directory. */ + Tcl_DString *bufferPtr; /* Uninitialized or free DString filled + * with name of user's home directory. */ +{ + struct passwd *pwPtr; + Tcl_DString ds; + char *native; + + native = Tcl_UtfToExternalDString(NULL, name, -1, &ds); + pwPtr = getpwnam(native); /* INTL: Native. */ + Tcl_DStringFree(&ds); + + if (pwPtr == NULL) { + endpwent(); + return NULL; + } + Tcl_ExternalToUtfDString(NULL, pwPtr->pw_dir, -1, bufferPtr); + endpwent(); + return Tcl_DStringValue(bufferPtr); +} + +/* + *--------------------------------------------------------------------------- + * * TclpAccess -- * * This function replaces the library version of access(). @@ -553,10 +400,168 @@ TclMatchFiles(interp, separators, dirPtr, pattern, tail) int TclpAccess(path, mode) - CONST char *path; /* Path of file to access. */ + CONST char *path; /* Path of file to access (UTF-8). */ int mode; /* Permission setting. */ { - return access(path, mode); + int result; + Tcl_DString ds; + char *native; + + native = Tcl_UtfToExternalDString(NULL, path, -1, &ds); + result = access(native, mode); /* INTL: Native. */ + Tcl_DStringFree(&ds); + + return result; +} + +/* + *--------------------------------------------------------------------------- + * + * TclpChdir -- + * + * This function replaces the library version of chdir(). + * + * Results: + * See chdir() documentation. + * + * Side effects: + * See chdir() documentation. + * + *--------------------------------------------------------------------------- + */ + +int +TclpChdir(dirName) + CONST char *dirName; /* Path to new working directory (UTF-8). */ +{ + int result; + Tcl_DString ds; + char *native; + + native = Tcl_UtfToExternalDString(NULL, dirName, -1, &ds); + result = chdir(native); /* INTL: Native. */ + Tcl_DStringFree(&ds); + + return result; +} + +/* + *---------------------------------------------------------------------- + * + * TclpLstat -- + * + * This function replaces the library version of lstat(). + * + * Results: + * See lstat() documentation. + * + * Side effects: + * See lstat() documentation. + * + *---------------------------------------------------------------------- + */ + +int +TclpLstat(path, bufPtr) + CONST char *path; /* Path of file to stat (UTF-8). */ + struct stat *bufPtr; /* Filled with results of stat call. */ +{ + int result; + Tcl_DString ds; + char *native; + + native = Tcl_UtfToExternalDString(NULL, path, -1, &ds); + result = lstat(native, bufPtr); /* INTL: Native. */ + Tcl_DStringFree(&ds); + + return result; +} + +/* + *--------------------------------------------------------------------------- + * + * TclpGetCwd -- + * + * This function replaces the library version of getcwd(). + * + * Results: + * The result is a pointer to a string specifying the current + * directory, or NULL if the current directory could not be + * determined. If NULL is returned, an error message is left in the + * interp's result. Storage for the result string is allocated in + * bufferPtr; the caller must call Tcl_DStringFree() when the result + * is no longer needed. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +char * +TclpGetCwd(interp, bufferPtr) + Tcl_Interp *interp; /* If non-NULL, used for error reporting. */ + Tcl_DString *bufferPtr; /* Uninitialized or free DString filled + * with name of current directory. */ +{ + char buffer[MAXPATHLEN+1]; + +#ifdef USEGETWD + if (getwd(buffer) == NULL) { /* INTL: Native. */ +#else + if (getcwd(buffer, MAXPATHLEN + 1) == NULL) { /* INTL: Native. */ +#endif + if (interp != NULL) { + Tcl_AppendResult(interp, + "error getting working directory name: ", + Tcl_PosixError(interp), (char *) NULL); + } + return NULL; + } + return Tcl_ExternalToUtfDString(NULL, buffer, -1, bufferPtr); +} + +/* + *--------------------------------------------------------------------------- + * + * TclpReadlink -- + * + * This function replaces the library version of readlink(). + * + * Results: + * The result is a pointer to a string specifying the contents + * of the symbolic link given by 'path', or NULL if the symbolic + * link could not be read. Storage for the result string is + * allocated in bufferPtr; the caller must call Tcl_DStringFree() + * when the result is no longer needed. + * + * Side effects: + * See readlink() documentation. + * + *--------------------------------------------------------------------------- + */ + +char * +TclpReadlink(path, linkPtr) + CONST char *path; /* Path of file to readlink (UTF-8). */ + Tcl_DString *linkPtr; /* Uninitialized or free DString filled + * with contents of link (UTF-8). */ +{ + char link[MAXPATHLEN]; + int length; + char *native; + Tcl_DString ds; + + native = Tcl_UtfToExternalDString(NULL, path, -1, &ds); + length = readlink(native, link, sizeof(link)); /* INTL: Native. */ + Tcl_DStringFree(&ds); + + if (length < 0) { + return NULL; + } + + Tcl_ExternalToUtfDString(NULL, link, length, linkPtr); + return Tcl_DStringValue(linkPtr); } /* @@ -577,9 +582,17 @@ TclpAccess(path, mode) int TclpStat(path, bufPtr) - CONST char *path; /* Path of file to stat. */ + CONST char *path; /* Path of file to stat (in UTF-8). */ struct stat *bufPtr; /* Filled with results of stat call. */ { - return stat(path, bufPtr); + int result; + Tcl_DString ds; + char *native; + + native = Tcl_UtfToExternalDString(NULL, path, -1, &ds); + result = stat(native, bufPtr); /* INTL: Native. */ + Tcl_DStringFree(&ds); + + return result; } diff --git a/unix/tclUnixInit.c b/unix/tclUnixInit.c index 30259ae..b561133 100644 --- a/unix/tclUnixInit.c +++ b/unix/tclUnixInit.c @@ -3,16 +3,17 @@ * * Contains the Unix-specific interpreter initialization functions. * - * 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. * - * RCS: @(#) $Id: tclUnixInit.c,v 1.12 1999/03/10 05:52:52 stanton Exp $ + * RCS: @(#) $Id: tclUnixInit.c,v 1.13 1999/04/16 00:48:05 stanton Exp $ */ #include "tclInt.h" #include "tclPort.h" +#include <locale.h> #if defined(__FreeBSD__) # include <floatingpoint.h> #endif @@ -24,6 +25,13 @@ #endif /* + * The Init script (common to Windows and Unix platforms) is + * defined in tkInitScript.h + */ +#include "tclInitScript.h" + + +/* * Default directory in which to look for Tcl library scripts. The * symbol is defined by Makefile. */ @@ -38,57 +46,363 @@ static char defaultLibraryDir[sizeof(TCL_LIBRARY)+200] = TCL_LIBRARY; static char pkgPath[sizeof(TCL_PACKAGE_PATH)+200] = TCL_PACKAGE_PATH; -/* - * Is this module initialized? - */ +typedef struct LocaleTable { + CONST char *lang; + CONST char *encoding; +} LocaleTable; + +static CONST LocaleTable localeTable[] = { + {"ja_JP.SJIS", "shiftjis"}, + {"ja_JP.EUC", "euc-jp"}, + {"ja_JP.JIS", "iso2022-jp"}, + {"ja_JP.mscode", "shiftjis"}, + {"ja_JP.ujis", "euc-jp"}, + {"ja_JP", "euc-jp"}, + {"Ja_JP", "shiftjis"}, + {"Jp_JP", "shiftjis"}, + {"japan", "euc-jp"}, +#ifdef hpux + {"japanese", "shiftjis"}, + {"ja", "shiftjis"}, +#else + {"japanese", "euc-jp"}, + {"ja", "euc-jp"}, +#endif + {"japanese.sjis", "shiftjis"}, + {"japanese.euc", "euc-jp"}, + {"japanese-sjis", "shiftjis"}, + {"japanese-ujis", "euc-jp"}, + + {"ko", "euc-kr"}, + {"ko_KR", "euc-kr"}, + {"ko_KR.EUC", "euc-kr"}, + {"ko_KR.euc", "euc-kr"}, + {"ko_KR.eucKR", "euc-kr"}, + {"korean", "euc-kr"}, -static int initialized = 0; + {"zh", "cp936"}, + {NULL, NULL} +}; + /* - * The Init script, tclPreInitScript variable, and the routine - * TclSetPreInitScript (common to Windows and Unix platforms) are defined - * in generic/tclInitScript.h. + *--------------------------------------------------------------------------- + * + * TclpInitPlatform -- + * + * Initialize all the platform-dependant things like signals and + * floating-point error handling. + * + * Called at process initialization time. + * + * Results: + * None. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- */ -#include "tclInitScript.h" +void +TclpInitPlatform() +{ + tclPlatform = TCL_PLATFORM_UNIX; + + /* + * The code below causes SIGPIPE (broken pipe) errors to + * be ignored. This is needed so that Tcl processes don't + * die if they create child processes (e.g. using "exec" or + * "open") that terminate prematurely. The signal handler + * is only set up when the first interpreter is created; + * after this the application can override the handler with + * a different one of its own, if it wants. + */ + +#ifdef SIGPIPE + (void) signal(SIGPIPE, SIG_IGN); +#endif /* SIGPIPE */ +#ifdef __FreeBSD__ + fpsetround(FP_RN); + fpsetmask(0L); +#endif + +#if defined(__bsdi__) && (_BSDI_VERSION > 199501) + /* + * Find local symbols. Don't report an error if we fail. + */ + (void) dlopen (NULL, RTLD_NOW); /* INTL: Native. */ +#endif +} + /* - * Static routines in this file: + *--------------------------------------------------------------------------- + * + * TclpInitLibraryPath -- + * + * Initialize the library path at startup. We have a minor + * metacircular problem that we don't know the encoding of the + * operating system but we may need to talk to operating system + * to find the library directories so that we know how to talk to + * the operating system. + * + * We do not know the encoding of the operating system. + * We do know that the encoding is some multibyte encoding. + * In that multibyte encoding, the characters 0..127 are equivalent + * to ascii. + * + * So although we don't know the encoding, it's safe: + * to look for the last slash character in a path in the encoding. + * to append an ascii string to a path. + * to pass those strings back to the operating system. + * + * But any strings that we remembered before we knew the encoding of + * the operating system must be translated to UTF-8 once we know the + * encoding so that the rest of Tcl can use those strings. + * + * This call sets the library path to strings in the unknown native + * encoding. TclpSetInitialEncodings() will translate the library + * path from the native encoding to UTF-8 as soon as it determines + * what the native encoding actually is. + * + * Called at process initialization time. + * + * Results: + * None. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- */ -static void PlatformInitExitHandler _ANSI_ARGS_((ClientData clientData)); +void +TclpInitLibraryPath(path) +CONST char *path; /* Path to the executable in native + * multi-byte encoding. */ +{ +#define LIBRARY_SIZE 32 + Tcl_Obj *pathPtr, *objPtr; + char *str; + Tcl_DString buffer, ds; + int pathc; + char **pathv; + char installLib[LIBRARY_SIZE], developLib[LIBRARY_SIZE]; + + Tcl_DStringInit(&ds); + pathPtr = Tcl_NewObj(); + + /* + * Initialize the substrings used when locating an executable. The + * installLib variable computes the path as though the executable + * is installed. The developLib computes the path as though the + * executable is run from a develpment directory. + */ + + sprintf(installLib, "lib/tcl%s", TCL_VERSION); + sprintf(developLib, "tcl%s/library", + ((TCL_RELEASE_LEVEL < 2) ? TCL_PATCH_LEVEL : TCL_VERSION)); + + /* + * Look for the library relative to default encoding dir. + */ + + str = Tcl_GetDefaultEncodingDir(); + if ((str != NULL) && (str[0] != '\0')) { + objPtr = Tcl_NewStringObj(str, -1); + Tcl_ListObjAppendElement(NULL, pathPtr, objPtr); + } + + /* + * Look for the library relative to the TCL_LIBRARY env variable. + * If the last dirname in the TCL_LIBRARY path does not match the + * last dirname in the installLib variable, use the last dir name + * of installLib in addition to the orginal TCL_LIBRARY path. + */ + + str = getenv("TCL_LIBRARY"); /* INTL: Native. */ + Tcl_ExternalToUtfDString(NULL, str, -1, &buffer); + str = Tcl_DStringValue(&buffer); + + if ((str != NULL) && (str[0] != '\0')) { + /* + * If TCL_LIBRARY is set, search there. + */ + + objPtr = Tcl_NewStringObj(str, -1); + Tcl_ListObjAppendElement(NULL, pathPtr, objPtr); + + Tcl_SplitPath(str, &pathc, &pathv); + if ((pathc > 0) && (strcasecmp(installLib + 4, pathv[pathc-1]) != 0)) { + /* + * If TCL_LIBRARY is set but refers to a different tcl + * installation than the current version, try fiddling with the + * specified directory to make it refer to this installation by + * removing the old "tclX.Y" and substituting the current + * version string. + */ + + pathv[pathc - 1] = installLib + 4; + str = Tcl_JoinPath(pathc, pathv, &ds); + objPtr = Tcl_NewStringObj(str, Tcl_DStringLength(&ds)); + Tcl_ListObjAppendElement(NULL, pathPtr, objPtr); + Tcl_DStringFree(&ds); + } + ckfree((char *) pathv); + } + + /* + * Look for the library relative to the executable. Use both the + * installLib and developLib because we cannot determine if this + * is installed or not. + */ + + if (path != NULL) { + Tcl_SplitPath(path, &pathc, &pathv); + if (pathc > 1) { + pathv[pathc - 2] = installLib; + path = Tcl_JoinPath(pathc - 1, pathv, &ds); + objPtr = Tcl_NewStringObj(path, Tcl_DStringLength(&ds)); + Tcl_ListObjAppendElement(NULL, pathPtr, objPtr); + Tcl_DStringFree(&ds); + } + if (pathc > 2) { + pathv[pathc - 3] = developLib; + path = Tcl_JoinPath(pathc - 2, pathv, &ds); + objPtr = Tcl_NewStringObj(path, Tcl_DStringLength(&ds)); + Tcl_ListObjAppendElement(NULL, pathPtr, objPtr); + Tcl_DStringFree(&ds); + } + ckfree((char *) pathv); + } + + /* + * Finally, look for the library relative to the compiled-in path. + * This is needed when users install Tcl with an exec-prefix that + * is different from the prtefix. + */ + + str = defaultLibraryDir; + if (str[0] != '\0') { + objPtr = Tcl_NewStringObj(str, -1); + Tcl_ListObjAppendElement(NULL, pathPtr, objPtr); + } + + TclSetLibraryPath(pathPtr); + Tcl_DStringFree(&buffer); +} /* - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- * - * PlatformInitExitHandler -- + * TclpSetInitialEncodings -- * - * Uninitializes all values on unload, so that this module can - * be later reinitialized. + * Based on the locale, determine the encoding of the operating + * system and the default encoding for newly opened files. + * + * Called at process initialization time. * * Results: * None. * * Side effects: - * Returns the module to uninitialized state. + * The Tcl library path is converted from native encoding to UTF-8. * - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- */ -static void -PlatformInitExitHandler(clientData) - ClientData clientData; /* Unused. */ +void +TclpSetInitialEncodings() { - initialized = 0; + CONST char *encoding; + int i; + Tcl_Obj *pathPtr; + char *langEnv; + + /* + * Determine the current encoding from the LC_TYPE or LANG environment + * variables. We previously used setlocale() to determine the locale, + * but this does not work on some systems (e.g. Linux/i386 RH 5.0). + */ + + langEnv = getenv("LC_CTYPE"); + + if (langEnv == NULL || langEnv[0] == '\0') { + langEnv = getenv("LANG"); + } + if (langEnv == NULL || langEnv[0] == '\0') { + langEnv = NULL; + } + + encoding = "iso8859-1"; + if (langEnv != NULL) { + for (i = 0; localeTable[i].lang != NULL; i++) { + if (strcmp(localeTable[i].lang, langEnv) == 0) { + encoding = localeTable[i].encoding; + } + } + } + + Tcl_SetSystemEncoding(NULL, encoding); + + /* + * Until the system encoding was actually set, the library path was + * actually in the native multi-byte encoding, and not really UTF-8 + * as advertised. We cheated as follows: + * + * 1. It was safe to allow the Tcl_SetSystemEncoding() call to + * append the ASCII chars that make up the encoding's filename to + * the names (in the native encoding) of directories in the library + * path, since all Unix multi-byte encodings have ASCII in the + * beginning. + * + * 2. To open the encoding file, the native bytes in the file name + * were passed to the OS, without translating from UTF-8 to native, + * because the name was already in the native encoding. + * + * Now that the system encoding was actually successfully set, + * translate all the names in the library path to UTF-8. That way, + * next time we search the library path, we'll translate the names + * from UTF-8 to the system encoding which will be the native + * encoding. + */ + + pathPtr = TclGetLibraryPath(); + if (pathPtr != NULL) { + int objc; + Tcl_Obj **objv; + + objc = 0; + Tcl_ListObjGetElements(NULL, pathPtr, &objc, &objv); + for (i = 0; i < objc; i++) { + int length; + char *string; + Tcl_DString ds; + + string = Tcl_GetStringFromObj(objv[i], &length); + Tcl_ExternalToUtfDString(NULL, string, length, &ds); + Tcl_SetStringObj(objv[i], Tcl_DStringValue(&ds), + Tcl_DStringLength(&ds)); + Tcl_DStringFree(&ds); + } + } + + /* + * Keep the iso8859-1 encoding preloaded. The IO package uses it for + * gets on a binary channel. + */ + + Tcl_GetEncoding(NULL, "iso8859-1"); } /* - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- * - * TclPlatformInit -- + * TclpSetVariables -- * - * Performs Unix-specific interpreter initialization related to the - * tcl_library and tcl_platform variables, and other platform- + * Performs platform-specific interpreter initialization related to + * the tcl_library and tcl_platform variables, and other platform- * specific things. * * Results: @@ -101,25 +415,30 @@ PlatformInitExitHandler(clientData) */ void -TclPlatformInit(interp) +TclpSetVariables(interp) Tcl_Interp *interp; { #ifndef NO_UNAME struct utsname name; #endif int unameOK; + char *user; + Tcl_DString ds; - tclPlatform = TCL_PLATFORM_UNIX; - Tcl_SetVar(interp, "tclDefaultLibrary", defaultLibraryDir, - TCL_GLOBAL_ONLY); + Tcl_SetVar(interp, "tcl_library", defaultLibraryDir, TCL_GLOBAL_ONLY); Tcl_SetVar(interp, "tcl_pkgPath", pkgPath, TCL_GLOBAL_ONLY); Tcl_SetVar2(interp, "tcl_platform", "platform", "unix", TCL_GLOBAL_ONLY); unameOK = 0; #ifndef NO_UNAME if (uname(&name) >= 0) { + char *native; + unameOK = 1; - Tcl_SetVar2(interp, "tcl_platform", "os", name.sysname, - TCL_GLOBAL_ONLY); + + native = Tcl_ExternalToUtfDString(NULL, name.sysname, -1, &ds); + Tcl_SetVar2(interp, "tcl_platform", "os", native, TCL_GLOBAL_ONLY); + Tcl_DStringFree(&ds); + /* * The following code is a special hack to handle differences in * the way version information is returned by uname. On most @@ -129,7 +448,7 @@ TclPlatformInit(interp) */ if ((strchr(name.release, '.') != NULL) - || !isdigit(UCHAR(name.version[0]))) { + || !isdigit(UCHAR(name.version[0]))) { /* INTL: digit */ Tcl_SetVar2(interp, "tcl_platform", "osVersion", name.release, TCL_GLOBAL_ONLY); } else { @@ -150,42 +469,79 @@ TclPlatformInit(interp) Tcl_SetVar2(interp, "tcl_platform", "machine", "", TCL_GLOBAL_ONLY); } - if (!initialized) { + /* + * Copy USER or LOGNAME environment variable into tcl_platform(user) + */ - /* - * Create an exit handler so that uninitialization will be done - * on unload. - */ - - Tcl_CreateExitHandler(PlatformInitExitHandler, NULL); - - /* - * The code below causes SIGPIPE (broken pipe) errors to - * be ignored. This is needed so that Tcl processes don't - * die if they create child processes (e.g. using "exec" or - * "open") that terminate prematurely. The signal handler - * is only set up when the first interpreter is created; - * after this the application can override the handler with - * a different one of its own, if it wants. - */ - -#ifdef SIGPIPE - (void) signal(SIGPIPE, SIG_IGN); -#endif /* SIGPIPE */ + Tcl_DStringInit(&ds); + user = TclGetEnv("USER", &ds); + if (user == NULL) { + user = TclGetEnv("LOGNAME", &ds); + if (user == NULL) { + user = ""; + } + } + Tcl_SetVar2(interp, "tcl_platform", "user", user, TCL_GLOBAL_ONLY); + Tcl_DStringFree(&ds); -#ifdef __FreeBSD__ - fpsetround(FP_RN); - fpsetmask(0L); -#endif +} + +/* + *---------------------------------------------------------------------- + * + * TclpFindVariable -- + * + * Locate the entry in environ for a given name. On Unix this + * routine is case sensetive, on Windows this matches mioxed case. + * + * Results: + * The return value is the index in environ of an entry with the + * name "name", or -1 if there is no such entry. The integer at + * *lengthPtr is filled in with the length of name (if a matching + * entry is found) or the length of the environ array (if no matching + * entry is found). + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ -#if defined(__bsdi__) && (_BSDI_VERSION > 199501) - /* - * Find local symbols. Don't report an error if we fail. - */ - (void) dlopen (NULL, RTLD_NOW); -#endif - initialized = 1; +int +TclpFindVariable(name, lengthPtr) + CONST char *name; /* Name of desired environment variable + * (native). */ + int *lengthPtr; /* Used to return length of name (for + * successful searches) or number of non-NULL + * entries in environ (for unsuccessful + * searches). */ +{ + int i, result = -1; + register CONST char *env, *p1, *p2; + Tcl_DString envString; + + Tcl_DStringInit(&envString); + for (i = 0, env = environ[i]; env != NULL; i++, env = environ[i]) { + p1 = Tcl_ExternalToUtfDString(NULL, env, -1, &envString); + p2 = name; + + for (; *p2 == *p1; p1++, p2++) { + /* NULL loop body. */ + } + if ((*p1 == '=') && (*p2 == '\0')) { + *lengthPtr = p2 - name; + result = i; + goto done; + } + + Tcl_DStringFree(&envString); } + + *lengthPtr = i; + + done: + Tcl_DStringFree(&envString); + return result; } /* @@ -194,12 +550,12 @@ TclPlatformInit(interp) * Tcl_Init -- * * This procedure is typically invoked by Tcl_AppInit procedures - * to perform additional initialization for a Tcl interpreter, - * such as sourcing the "init.tcl" script. + * to find and source the "init.tcl" script, which should exist + * somewhere on the Tcl library path. * * Results: - * Returns a standard Tcl completion code and sets interp->result - * if there is an error. + * Returns a standard Tcl completion code and sets the interp's + * result if there is an error. * * Side effects: * Depends on what's in the init.tcl script. @@ -211,12 +567,20 @@ int Tcl_Init(interp) Tcl_Interp *interp; /* Interpreter to initialize. */ { + Tcl_Obj *pathPtr; + if (tclPreInitScript != NULL) { if (Tcl_Eval(interp, tclPreInitScript) == TCL_ERROR) { return (TCL_ERROR); }; } - return(Tcl_Eval(interp, initScript)); + + pathPtr = TclGetLibraryPath(); + if (pathPtr == NULL) { + pathPtr = Tcl_NewObj(); + } + Tcl_SetVar2Ex(interp, "tcl_libPath", NULL, pathPtr, TCL_GLOBAL_ONLY); + return Tcl_Eval(interp, initScript); } /* @@ -271,8 +635,8 @@ Tcl_SourceRCFile(interp) 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_WriteObj(errChannel, Tcl_GetObjResult(interp)); + Tcl_WriteChars(errChannel, "\n", 1); } } } diff --git a/unix/tclUnixNotfy.c b/unix/tclUnixNotfy.c index 5e8cdb9..bbb34e0 100644 --- a/unix/tclUnixNotfy.c +++ b/unix/tclUnixNotfy.c @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclUnixNotfy.c,v 1.2 1998/09/14 18:40:17 stanton Exp $ + * RCS: @(#) $Id: tclUnixNotfy.c,v 1.3 1999/04/16 00:48:05 stanton Exp $ */ #include "tclInt.h" @@ -53,10 +53,11 @@ typedef struct FileHandlerEvent { /* * The following static structure contains the state information for the - * select based implementation of the Tcl notifier. + * select based implementation of the Tcl notifier. One of these structures + * is created for each thread that is using the notifier. */ -static struct { +typedef struct ThreadSpecificData { FileHandler *firstFileHandlerPtr; /* Pointer to head of file handler list. */ fd_mask checkMasks[3*MASK_SIZE]; @@ -71,70 +72,241 @@ static struct { int numFdBits; /* Number of valid bits in checkMasks * (one more than highest fd for which * Tcl_WatchFile has been called). */ -} notifier; +#ifdef TCL_THREADS + int onList; /* True if it is in this list */ + unsigned int pollState; /* pollState is used to implement a polling + * handshake between each thread and the + * notifier thread. Bits defined below. */ + struct ThreadSpecificData *nextPtr, *prevPtr; + /* All threads that are currently waiting on + * an event have their ThreadSpecificData + * structure on a doubly-linked listed formed + * from these pointers. You must hold the + * notifierMutex lock before accessing these + * fields. */ + Tcl_Condition waitCV; /* Any other thread alerts a notifier + * that an event is ready to be processed + * by signaling this condition variable. */ + int eventReady; /* True if an event is ready to be processed. + * Used as condition flag together with + * waitCV above. */ +#endif +} ThreadSpecificData; + +static Tcl_ThreadDataKey dataKey; + +#ifdef TCL_THREADS +/* + * The following static indicates the number of threads that have + * initialized notifiers. + * + * You must hold the notifierMutex lock before accessing this variable. + */ + +static int notifierCount = 0; + +/* + * The following variable points to the head of a doubly-linked list of + * of ThreadSpecificData structures for all threads that are currently + * waiting on an event. + * + * You must hold the notifierMutex lock before accessing this list. + */ + +static ThreadSpecificData *waitingListPtr = NULL; + +/* + * The notifier thread spends all its time in select() waiting for a + * file descriptor associated with one of the threads on the waitingListPtr + * list to do something interesting. But if the contents of the + * waitingListPtr list ever changes, we need to wake up and restart + * the select() system call. You can wake up the notifier thread by + * writing a single byte to the file descriptor defined below. This + * file descriptor is the input-end of a pipe and the notifier thread is + * listening for data on the output-end of the same pipe. Hence writing + * to this file descriptor will cause the select() system call to return + * and wake up the notifier thread. + * + * You must hold the notifierMutex lock before accessing this list. + */ + +static int triggerPipe = -1; + +/* + * The notifierMutex locks access to all of the global notifier state. + */ + +TCL_DECLARE_MUTEX(notifierMutex) + +/* + * The notifier thread signals the notifierCV when it has finished + * initializing the triggerPipe and right before the notifier + * thread terminates. + */ + +static Tcl_Condition notifierCV; + +/* + * The pollState bits + * POLL_WANT is set by each thread before it waits on its condition + * variable. It is checked by the notifier before it does + * select. + * POLL_DONE is set by the notifier if it goes into select after + * seeing POLL_WANT. The idea is to ensure it tries a select + * with the same bits the initial thread had set. + */ +#define POLL_WANT 0x1 +#define POLL_DONE 0x2 /* - * The following static indicates whether this module has been initialized. + * This is the thread ID of the notifier thread that does select. */ +static Tcl_ThreadId notifierThread; -static int initialized = 0; +#endif /* * 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)); +#ifdef TCL_THREADS +static void NotifierThreadProc _ANSI_ARGS_((ClientData clientData)); +#endif +static int FileHandlerEventProc _ANSI_ARGS_((Tcl_Event *evPtr, + int flags)); /* *---------------------------------------------------------------------- * - * InitNotifier -- + * Tcl_InitNotifier -- * - * Initializes the notifier state. + * Initializes the platform specific notifier state. * * Results: - * None. + * Returns a handle to the notifier state for this thread.. * * Side effects: - * Creates a new exit handler. + * None. * *---------------------------------------------------------------------- */ -static void -InitNotifier() +ClientData +Tcl_InitNotifier() { - initialized = 1; - memset(¬ifier, 0, sizeof(notifier)); - Tcl_CreateExitHandler(NotifierExitHandler, NULL); + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + +#ifdef TCL_THREADS + tsdPtr->eventReady = 0; + + /* + * Start the Notifier thread if necessary. + */ + + Tcl_MutexLock(¬ifierMutex); + if (notifierCount == 0) { + if (TclpThreadCreate(¬ifierThread, NotifierThreadProc, NULL) != TCL_OK) { + panic("Tcl_InitNotifier: unable to start notifier thread"); + } + } + notifierCount++; + + /* + * Wait for the notifier pipe to be created. + */ + + while (triggerPipe < 0) { + Tcl_ConditionWait(¬ifierCV, ¬ifierMutex, NULL); + } + + Tcl_MutexUnlock(¬ifierMutex); +#endif + return tsdPtr; } /* *---------------------------------------------------------------------- * - * NotifierExitHandler -- + * Tcl_FinalizeNotifier -- * * This function is called to cleanup the notifier state before - * Tcl is unloaded. + * a thread is terminated. * * Results: * None. * * Side effects: - * Destroys the notifier window. + * May terminate the background notifier thread if this is the + * last notifier instance. * *---------------------------------------------------------------------- */ -static void -NotifierExitHandler(clientData) +void +Tcl_FinalizeNotifier(clientData) ClientData clientData; /* Not used. */ { - initialized = 0; +#ifdef TCL_THREADS + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + + Tcl_MutexLock(¬ifierMutex); + notifierCount--; + + /* + * If this is the last thread to use the notifier, close the notifier + * pipe and wait for the background thread to terminate. + */ + + if (notifierCount == 0) { + if (triggerPipe < 0) { + panic("Tcl_FinalizeNotifier: notifier pipe not initialized"); + } + close(triggerPipe); + Tcl_ConditionWait(¬ifierCV, ¬ifierMutex, NULL); + } + + /* + * Clean up any synchronization objects in the thread local storage. + */ + + TclFinalizeCondition(&(tsdPtr->waitCV)); + + Tcl_MutexUnlock(¬ifierMutex); +#endif +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_AlertNotifier -- + * + * Wake up the specified notifier from any thread. This routine + * is called by the platform independent notifier code whenever + * the Tcl_ThreadAlert routine is called. This routine is + * guaranteed not to be called on a given notifier after + * Tcl_FinalizeNotifier is called for that notifier. + * + * Results: + * None. + * + * Side effects: + * Signals the notifier condition variable for the specified + * notifier. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_AlertNotifier(clientData) + ClientData clientData; +{ +#ifdef TCL_THREADS + ThreadSpecificData *tsdPtr = (ThreadSpecificData *) clientData; + Tcl_MutexLock(¬ifierMutex); + tsdPtr->eventReady = 1; + Tcl_ConditionNotify(&tsdPtr->waitCV); + Tcl_MutexUnlock(¬ifierMutex); +#endif } /* @@ -169,6 +341,29 @@ Tcl_SetTimer(timePtr) /* *---------------------------------------------------------------------- * + * Tcl_ServiceModeHook -- + * + * This function is invoked whenever the service mode changes. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_ServiceModeHook(mode) + int mode; /* Either TCL_SERVICE_ALL, or + * TCL_SERVICE_NONE. */ +{ +} + +/* + *---------------------------------------------------------------------- + * * Tcl_CreateFileHandler -- * * This procedure registers a file handler with the Xt notifier. @@ -194,25 +389,22 @@ Tcl_CreateFileHandler(fd, mask, proc, clientData) * selected event. */ ClientData clientData; /* Arbitrary data to pass to proc. */ { + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); FileHandler *filePtr; int index, bit; - - if (!initialized) { - InitNotifier(); - } - for (filePtr = notifier.firstFileHandlerPtr; filePtr != NULL; - filePtr = filePtr->nextPtr) { + for (filePtr = tsdPtr->firstFileHandlerPtr; filePtr != NULL; + filePtr = filePtr->nextPtr) { if (filePtr->fd == fd) { break; } } if (filePtr == NULL) { - filePtr = (FileHandler*) ckalloc(sizeof(FileHandler)); /* MLK */ + filePtr = (FileHandler*) ckalloc(sizeof(FileHandler)); filePtr->fd = fd; filePtr->readyMask = 0; - filePtr->nextPtr = notifier.firstFileHandlerPtr; - notifier.firstFileHandlerPtr = filePtr; + filePtr->nextPtr = tsdPtr->firstFileHandlerPtr; + tsdPtr->firstFileHandlerPtr = filePtr; } filePtr->proc = proc; filePtr->clientData = clientData; @@ -225,22 +417,22 @@ Tcl_CreateFileHandler(fd, mask, proc, clientData) index = fd/(NBBY*sizeof(fd_mask)); bit = 1 << (fd%(NBBY*sizeof(fd_mask))); if (mask & TCL_READABLE) { - notifier.checkMasks[index] |= bit; + tsdPtr->checkMasks[index] |= bit; } else { - notifier.checkMasks[index] &= ~bit; + tsdPtr->checkMasks[index] &= ~bit; } if (mask & TCL_WRITABLE) { - (notifier.checkMasks+MASK_SIZE)[index] |= bit; + (tsdPtr->checkMasks+MASK_SIZE)[index] |= bit; } else { - (notifier.checkMasks+MASK_SIZE)[index] &= ~bit; + (tsdPtr->checkMasks+MASK_SIZE)[index] &= ~bit; } if (mask & TCL_EXCEPTION) { - (notifier.checkMasks+2*(MASK_SIZE))[index] |= bit; + (tsdPtr->checkMasks+2*(MASK_SIZE))[index] |= bit; } else { - (notifier.checkMasks+2*(MASK_SIZE))[index] &= ~bit; + (tsdPtr->checkMasks+2*(MASK_SIZE))[index] &= ~bit; } - if (notifier.numFdBits <= fd) { - notifier.numFdBits = fd+1; + if (tsdPtr->numFdBits <= fd) { + tsdPtr->numFdBits = fd+1; } } @@ -268,18 +460,14 @@ Tcl_DeleteFileHandler(fd) FileHandler *filePtr, *prevPtr; int index, bit, i; unsigned long flags; - - if (!initialized) { - InitNotifier(); - } + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); /* - * Find the entry for the given file (and return if there - * isn't one). + * 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) { + for (prevPtr = NULL, filePtr = tsdPtr->firstFileHandlerPtr; ; + prevPtr = filePtr, filePtr = filePtr->nextPtr) { if (filePtr == NULL) { return; } @@ -296,31 +484,31 @@ Tcl_DeleteFileHandler(fd) bit = 1 << (fd%(NBBY*sizeof(fd_mask))); if (filePtr->mask & TCL_READABLE) { - notifier.checkMasks[index] &= ~bit; + tsdPtr->checkMasks[index] &= ~bit; } if (filePtr->mask & TCL_WRITABLE) { - (notifier.checkMasks+MASK_SIZE)[index] &= ~bit; + (tsdPtr->checkMasks+MASK_SIZE)[index] &= ~bit; } if (filePtr->mask & TCL_EXCEPTION) { - (notifier.checkMasks+2*(MASK_SIZE))[index] &= ~bit; + (tsdPtr->checkMasks+2*(MASK_SIZE))[index] &= ~bit; } /* * Find current max fd. */ - if (fd+1 == notifier.numFdBits) { - for (notifier.numFdBits = 0; index >= 0; index--) { - flags = notifier.checkMasks[index] - | (notifier.checkMasks+MASK_SIZE)[index] - | (notifier.checkMasks+2*(MASK_SIZE))[index]; + if (fd+1 == tsdPtr->numFdBits) { + for (tsdPtr->numFdBits = 0; index >= 0; index--) { + flags = tsdPtr->checkMasks[index] + | (tsdPtr->checkMasks+MASK_SIZE)[index] + | (tsdPtr->checkMasks+2*(MASK_SIZE))[index]; if (flags) { for (i = (NBBY*sizeof(fd_mask)); i > 0; i--) { if (flags & (((unsigned long)1) << (i-1))) { break; } } - notifier.numFdBits = index * (NBBY*sizeof(fd_mask)) + i; + tsdPtr->numFdBits = index * (NBBY*sizeof(fd_mask)) + i; break; } } @@ -331,7 +519,7 @@ Tcl_DeleteFileHandler(fd) */ if (prevPtr == NULL) { - notifier.firstFileHandlerPtr = filePtr->nextPtr; + tsdPtr->firstFileHandlerPtr = filePtr->nextPtr; } else { prevPtr->nextPtr = filePtr->nextPtr; } @@ -366,9 +554,10 @@ FileHandlerEventProc(evPtr, flags) int flags; /* Flags that indicate what events to * handle, such as TCL_FILE_EVENTS. */ { + int mask; FileHandler *filePtr; FileHandlerEvent *fileEvPtr = (FileHandlerEvent *) evPtr; - int mask; + ThreadSpecificData *tsdPtr; if (!(flags & TCL_FILE_EVENTS)) { return 0; @@ -381,8 +570,9 @@ FileHandlerEventProc(evPtr, flags) * while the event is queued without leaving a dangling pointer. */ - for (filePtr = notifier.firstFileHandlerPtr; filePtr != NULL; - filePtr = filePtr->nextPtr) { + tsdPtr = TCL_TSD_INIT(&dataKey); + for (filePtr = tsdPtr->firstFileHandlerPtr; filePtr != NULL; + filePtr = filePtr->nextPtr) { if (filePtr->fd != fileEvPtr->fd) { continue; } @@ -435,11 +625,13 @@ Tcl_WaitForEvent(timePtr) FileHandler *filePtr; FileHandlerEvent *fileEvPtr; struct timeval timeout, *timeoutPtr; - int bit, index, mask, numFound; - - if (!initialized) { - InitNotifier(); - } + int bit, index, mask; +#ifdef TCL_THREADS + int waitForFiles; +#else + int numFound; +#endif + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); /* * Set up the timeout structure. Note that if there are no events to @@ -451,18 +643,108 @@ Tcl_WaitForEvent(timePtr) timeout.tv_sec = timePtr->sec; timeout.tv_usec = timePtr->usec; timeoutPtr = &timeout; - } else if (notifier.numFdBits == 0) { +#ifndef TCL_THREADS + } else if (tsdPtr->numFdBits == 0) { + /* + * If there are no threads, no timeout, and no fds registered, + * then there are no events possible and we must avoid deadlock. + * Note that this is not entirely correct because there might + * be a signal that could interrupt the select call, but we + * don't handle that case if we aren't using threads. + */ + return -1; +#endif } else { timeoutPtr = NULL; } - memcpy((VOID *) notifier.readyMasks, (VOID *) notifier.checkMasks, +#ifdef TCL_THREADS + /* + * Place this thread on the list of interested threads, signal the + * notifier thread, and wait for a response or a timeout. + */ + + Tcl_MutexLock(¬ifierMutex); + + waitForFiles = (tsdPtr->numFdBits > 0); + if (timePtr != NULL && timePtr->sec == 0 && timePtr->usec == 0) { + /* + * Cannot emulate a polling select with a polling condition variable. + * Instead, pretend to wait for files and tell the notifier + * thread what we are doing. The notifier thread makes sure + * it goes through select with its select mask in the same state + * as ours currently is. We block until that happens. + */ + + waitForFiles = 1; + tsdPtr->pollState = POLL_WANT; + timePtr = NULL; + } else { + tsdPtr->pollState = 0; + } + + if (waitForFiles) { + /* + * Add the ThreadSpecificData structure of this thread to the list + * of ThreadSpecificData structures of all threads that are waiting + * on file events. + */ + + + tsdPtr->nextPtr = waitingListPtr; + if (waitingListPtr) { + waitingListPtr->prevPtr = tsdPtr; + } + tsdPtr->prevPtr = 0; + waitingListPtr = tsdPtr; + tsdPtr->onList = 1; + + Tcl_MutexUnlock(¬ifierMutex); + write(triggerPipe, "", 1); + Tcl_MutexLock(¬ifierMutex); + } + + memset((VOID *) tsdPtr->readyMasks, 0, 3*MASK_SIZE*sizeof(fd_mask)); + + if (!tsdPtr->eventReady) { + + Tcl_ConditionWait(&tsdPtr->waitCV, ¬ifierMutex, timePtr); + } + tsdPtr->eventReady = 0; + + if (waitForFiles && tsdPtr->onList) { + /* + * Remove the ThreadSpecificData structure of this thread from the + * waiting list. Alert the notifier thread to recompute its select + * masks - skipping this caused a hang when trying to close a pipe + * which the notifier thread was still doing a select on. + */ + + if (tsdPtr->prevPtr) { + tsdPtr->prevPtr->nextPtr = tsdPtr->nextPtr; + } else { + waitingListPtr = tsdPtr->nextPtr; + } + if (tsdPtr->nextPtr) { + tsdPtr->nextPtr->prevPtr = tsdPtr->prevPtr; + } + tsdPtr->nextPtr = tsdPtr->prevPtr = NULL; + tsdPtr->onList = 0; + Tcl_MutexUnlock(¬ifierMutex); + write(triggerPipe, "", 1); + Tcl_MutexLock(¬ifierMutex); + + } + + +#else + memcpy((VOID *) tsdPtr->readyMasks, (VOID *) tsdPtr->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); + numFound = select(tsdPtr->numFdBits, + (SELECT_MASK *) &tsdPtr->readyMasks[0], + (SELECT_MASK *) &tsdPtr->readyMasks[MASK_SIZE], + (SELECT_MASK *) &tsdPtr->readyMasks[2*MASK_SIZE], timeoutPtr); /* * Some systems don't clear the masks after an error, so @@ -470,34 +752,32 @@ Tcl_WaitForEvent(timePtr) */ if (numFound == -1) { - memset((VOID *) notifier.readyMasks, 0, 3*MASK_SIZE*sizeof(fd_mask)); + memset((VOID *) tsdPtr->readyMasks, 0, 3*MASK_SIZE*sizeof(fd_mask)); } +#endif /* * Queue all detected file events before returning. */ - for (filePtr = notifier.firstFileHandlerPtr; - (filePtr != NULL) && (numFound > 0); - filePtr = filePtr->nextPtr) { + for (filePtr = tsdPtr->firstFileHandlerPtr; (filePtr != NULL); + filePtr = filePtr->nextPtr) { index = filePtr->fd / (NBBY*sizeof(fd_mask)); bit = 1 << (filePtr->fd % (NBBY*sizeof(fd_mask))); mask = 0; - if (notifier.readyMasks[index] & bit) { + if (tsdPtr->readyMasks[index] & bit) { mask |= TCL_READABLE; } - if ((notifier.readyMasks+MASK_SIZE)[index] & bit) { + if ((tsdPtr->readyMasks+MASK_SIZE)[index] & bit) { mask |= TCL_WRITABLE; } - if ((notifier.readyMasks+2*(MASK_SIZE))[index] & bit) { + if ((tsdPtr->readyMasks+2*(MASK_SIZE))[index] & bit) { mask |= TCL_EXCEPTION; } if (!mask) { continue; - } else { - numFound--; } /* @@ -514,5 +794,200 @@ Tcl_WaitForEvent(timePtr) } filePtr->readyMask = mask; } +#ifdef TCL_THREADS + Tcl_MutexUnlock(¬ifierMutex); +#endif return 0; } + +#ifdef TCL_THREADS +/* + *---------------------------------------------------------------------- + * + * NotifierThreadProc -- + * + * This routine is the initial (and only) function executed by the + * special notifier thread. Its job is to wait for file descriptors + * to become readable or writable or to have an exception condition + * and then to notify other threads who are interested in this + * information by signalling a condition variable. Other threads + * can signal this notifier thread of a change in their interests + * by writing a single byte to a special pipe that the notifier + * thread is monitoring. + * + * Result: + * None. Once started, this routine never exits. It dies with + * the overall process. + * + * Side effects: + * The trigger pipe used to signal the notifier thread is created + * when the notifier thread first starts. + * + *---------------------------------------------------------------------- + */ + +static void +NotifierThreadProc(clientData) + ClientData clientData; /* Not used. */ +{ + ThreadSpecificData *tsdPtr; + fd_mask masks[3*MASK_SIZE]; + long *maskPtr = (long *)masks; /* masks[] cast to type long[] */ + int fds[2]; + int i, status, index, bit, numFdBits, found, receivePipe, word; + struct timeval poll = {0., 0.}, *timePtr; + int maskSize = 3 * ((MASK_SIZE) / sizeof(long)) * sizeof(fd_mask); + char buf[2]; + + if (pipe(fds) != 0) { + panic("NotifierThreadProc: could not create trigger pipe."); + } + + receivePipe = fds[0]; + +#ifndef USE_FIONBIO + status = fcntl(receivePipe, F_GETFL); + status |= O_NONBLOCK; + if (fcntl(receivePipe, F_SETFL, status) < 0) { + panic("NotifierThreadProc: could not make receive pipe non blocking."); + } +#else + if (ioctl(receivePipe, (int) FIONBIO, &status) < 0) { + panic("NotifierThreadProc: could not make receive pipe non blocking."); + } +#endif + + /* + * Install the write end of the pipe into the global variable. + */ + + Tcl_MutexLock(¬ifierMutex); + triggerPipe = fds[1]; + + /* + * Signal any threads that are waiting. + */ + + Tcl_ConditionNotify(¬ifierCV); + Tcl_MutexUnlock(¬ifierMutex); + + /* + * Look for file events and report them to interested threads. + */ + + while (1) { + /* + * Set up the select mask to include the receive pipe. + */ + + memset((VOID *)masks, 0, 3*MASK_SIZE*sizeof(fd_mask)); + numFdBits = receivePipe + 1; + index = receivePipe / (NBBY*sizeof(fd_mask)); + bit = 1 << (receivePipe % (NBBY*sizeof(fd_mask))); + masks[index] |= bit; + + /* + * Add in the check masks from all of the waiting notifiers. + */ + + Tcl_MutexLock(¬ifierMutex); + timePtr = NULL; + for (tsdPtr = waitingListPtr; tsdPtr; tsdPtr = tsdPtr->nextPtr) { + for (i = 0; i < maskSize; i++) { + maskPtr[i] |= ((long*)tsdPtr->checkMasks)[i]; + } + if (tsdPtr->numFdBits > numFdBits) { + numFdBits = tsdPtr->numFdBits; + } + if (tsdPtr->pollState & POLL_WANT) { + /* + * Here we make sure we go through select() with the same + * mask bits that were present when the thread tried to poll. + */ + + tsdPtr->pollState |= POLL_DONE; + timePtr = &poll; + } + } + Tcl_MutexUnlock(¬ifierMutex); + + maskSize = 3 * ((MASK_SIZE) / sizeof(long)) * sizeof(fd_mask); + + if (select(numFdBits, (SELECT_MASK *) &masks[0], + (SELECT_MASK *) &masks[MASK_SIZE], + (SELECT_MASK *) &masks[2*MASK_SIZE], timePtr) == -1) { + /* + * Try again immediately on an error. + */ + + continue; + } + + /* + * Alert any threads that are waiting on a ready file descriptor. + */ + + Tcl_MutexLock(¬ifierMutex); + for (tsdPtr = waitingListPtr; tsdPtr; tsdPtr = tsdPtr->nextPtr) { + found = 0; + + for (i = 0; i < maskSize; i++) { + word = maskPtr[i] & ((long*)tsdPtr->checkMasks)[i]; + found |= word; + (((long*)(tsdPtr->readyMasks))[i]) = word; + } + if (found || (tsdPtr->pollState & POLL_DONE)) { + tsdPtr->eventReady = 1; + Tcl_ConditionNotify(&tsdPtr->waitCV); + if (tsdPtr->onList) { + /* + * Remove the ThreadSpecificData structure of this thread + * from the waiting list. This prevents us from continuously + * spining on select until the other threads runs and + * services the file event. + */ + + if (tsdPtr->prevPtr) { + tsdPtr->prevPtr->nextPtr = tsdPtr->nextPtr; + } else { + waitingListPtr = tsdPtr->nextPtr; + } + if (tsdPtr->nextPtr) { + tsdPtr->nextPtr->prevPtr = tsdPtr->prevPtr; + } + tsdPtr->nextPtr = tsdPtr->prevPtr = NULL; + tsdPtr->onList = 0; + tsdPtr->pollState = 0; + } + } + } + Tcl_MutexUnlock(¬ifierMutex); + + /* + * Consume the next byte from the notifier pipe if the pipe was + * readable. Note that there may be multiple bytes pending, but + * to avoid a race condition we only read one at a time. + */ + + if ((masks[index] & bit) && (read(receivePipe, buf, 1) == 0)) { + /* + * Someone closed the write end of the pipe so we need to + * shut down the notifier thread. + */ + + break; + } + } + + /* + * Clean up the read end of the pipe and signal any threads waiting on + * termination of the notifier thread. + */ + + close(receivePipe); + Tcl_MutexLock(¬ifierMutex); + triggerPipe = -1; + Tcl_ConditionNotify(¬ifierCV); + Tcl_MutexUnlock(¬ifierMutex); +} +#endif diff --git a/unix/tclUnixPipe.c b/unix/tclUnixPipe.c index 871830c..b78715c 100644 --- a/unix/tclUnixPipe.c +++ b/unix/tclUnixPipe.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. * - * RCS: @(#) $Id: tclUnixPipe.c,v 1.2 1998/09/14 18:40:17 stanton Exp $ + * RCS: @(#) $Id: tclUnixPipe.c,v 1.3 1999/04/16 00:48:05 stanton Exp $ */ #include "tclInt.h" @@ -128,12 +128,16 @@ TclpMakeFile(channel, direction) TclFile TclpOpenFile(fname, mode) - char *fname; /* The name of the file to open. */ - int mode; /* In what mode to open the file? */ + CONST char *fname; /* The name of the file to open. */ + int mode; /* In what mode to open the file? */ { int fd; + char *native; + Tcl_DString ds; - fd = open(fname, mode, 0666); + native = Tcl_UtfToExternalDString(NULL, fname, -1, &ds); + fd = open(native, mode, 0666); /* INTL: Native. */ + Tcl_DStringFree(&ds); if (fd != -1) { fcntl(fd, F_SETFD, FD_CLOEXEC); @@ -175,36 +179,28 @@ TclpOpenFile(fname, mode) */ 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. */ +TclpCreateTempFile(contents) + CONST char *contents; /* String to write into temp file, or NULL. */ { 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; - } + int fd; + + tmpnam(fileName); /* INTL: Native. */ + fd = open(fileName, O_RDWR|O_CREAT|O_TRUNC, 0666); /* INTL: Native. */ + if (fd == -1) { + return NULL; + } + fcntl(fd, F_SETFD, FD_CLOEXEC); + unlink(fileName); /* INTL: Native. */ + + if (contents != NULL) { + if (write(fd, contents, strlen(contents)) == -1) { + close(fd); + return NULL; } lseek(fd, 0, SEEK_SET); } - if (namePtr != NULL) { - Tcl_DStringAppend(namePtr, fileName, -1); - } - return file; + return MakeFile(fd); } /* @@ -279,7 +275,7 @@ TclpCloseFile(file) } /* - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- * * TclpCreateProcess -- * @@ -292,14 +288,14 @@ TclpCloseFile(file) * * Results: * The return value is TCL_ERROR and an error message is left in - * interp->result if there was a problem creating the child + * the interp's result if there was a problem creating the child * process. Otherwise, the return value is TCL_OK and *pidPtr is * filled with the process id of the child process. * * Side effects: * A process is created. * - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- */ /* ARGSUSED */ @@ -311,11 +307,11 @@ TclpCreateProcess(interp, argc, argv, inputFile, outputFile, errorFile, * 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. */ + char **argv; /* Array of argument strings in UTF-8. + * argv[0] contains the name of the executable + * translated using Tcl_TranslateFileName + * call). Additional arguments have not been + * converted. */ TclFile inputFile; /* If non-NULL, gives the file to use as * input for the child process. If inputFile * file is not readable or is NULL, the child @@ -336,7 +332,7 @@ TclpCreateProcess(interp, argc, argv, inputFile, outputFile, errorFile, { TclFile errPipeIn, errPipeOut; int joinThisError, count, status, fd; - char errSpace[200]; + char errSpace[200 + TCL_INTEGER_SPACE]; int pid; errPipeIn = NULL; @@ -357,6 +353,10 @@ TclpCreateProcess(interp, argc, argv, inputFile, outputFile, errorFile, joinThisError = (errorFile == outputFile); pid = vfork(); if (pid == 0) { + Tcl_DString *dsArray; + char *oldArgv0; + int i; + fd = GetFd(errPipeOut); /* @@ -381,9 +381,19 @@ TclpCreateProcess(interp, argc, argv, inputFile, outputFile, errorFile, */ RestoreSignals(); - execvp(argv[0], &argv[0]); + for (i = 0; argv[i] != NULL; i++) { + /* + * How many arguments? + */ + } + oldArgv0 = argv[0]; + dsArray = (Tcl_DString *) ckalloc(i * sizeof(Tcl_DString)); + for (i = 0; argv[i] != NULL; i++) { + argv[i] = Tcl_UtfToExternalDString(NULL, argv[i], -1, &dsArray[i]); + } + execvp(argv[0], argv); /* INTL: Native. */ sprintf(errSpace, "%dcouldn't execute \"%.150s\": ", errno, - argv[0]); + oldArgv0); write(fd, errSpace, (size_t) strlen(errSpace)); _exit(1); } @@ -621,7 +631,7 @@ TclpCreateCommandChannel(readFile, writeFile, errorFile, numPids, pidPtr) * the channel is closed or the processes * are detached (in a background exec). */ { - char channelName[20]; + char channelName[16 + TCL_INTEGER_SPACE]; int channelId; PipeState *statePtr = (PipeState *) ckalloc((unsigned) sizeof(PipeState)); int mode; @@ -676,13 +686,13 @@ TclpCreateCommandChannel(readFile, writeFile, errorFile, numPids, pidPtr) * 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. + * in the interp's result and to detach the processes. * * Results: * None. * * Side effects: - * Modifies interp->result. Detaches processes. + * Modifies the interp's result. Detaches processes. * *---------------------------------------------------------------------- */ @@ -695,7 +705,7 @@ TclGetAndDetachPids(interp, chan) PipeState *pipePtr; Tcl_ChannelType *chanTypePtr; int i; - char buf[20]; + char buf[TCL_INTEGER_SPACE]; /* * Punt if the channel is not a command channel. @@ -708,7 +718,7 @@ TclGetAndDetachPids(interp, chan) pipePtr = (PipeState *) Tcl_GetChannelInstanceData(chan); for (i = 0; i < pipePtr->numPids; i++) { - sprintf(buf, "%ld", TclpGetPid(pipePtr->pidPtr[i])); + TclFormatInt(buf, (long) TclpGetPid(pipePtr->pidPtr[i])); Tcl_AppendElement(interp, buf); Tcl_DetachPids(1, &(pipePtr->pidPtr[i])); } @@ -1129,8 +1139,7 @@ Tcl_PidObjCmd(dummy, interp, objc, objv) if (objc == 1) { Tcl_SetLongObj(Tcl_GetObjResult(interp), (long) getpid()); } else { - chan = Tcl_GetChannel(interp, Tcl_GetStringFromObj(objv[1], NULL), - NULL); + chan = Tcl_GetChannel(interp, Tcl_GetString(objv[1]), NULL); if (chan == (Tcl_Channel) NULL) { return TCL_ERROR; } diff --git a/unix/tclUnixPort.h b/unix/tclUnixPort.h index 6ab38ee..89ebf7f 100644 --- a/unix/tclUnixPort.h +++ b/unix/tclUnixPort.h @@ -14,12 +14,12 @@ * by Karl Lehenbauer, Mark Diekhans and Peter da Silva. * * Copyright (c) 1991-1994 The Regents of the University of California. - * Copyright (c) 1994-1995 Sun Microsystems, Inc. + * Copyright (c) 1994-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclUnixPort.h,v 1.10 1999/03/11 00:19:24 stanton Exp $ + * RCS: @(#) $Id: tclUnixPort.h,v 1.11 1999/04/16 00:48:05 stanton Exp $ */ #ifndef _TCLUNIXPORT @@ -28,6 +28,14 @@ #ifndef _TCLINT # include "tclInt.h" #endif + +/* + *--------------------------------------------------------------------------- + * The following sets of #includes and #ifdefs are required to get Tcl to + * compile under the various flavors of unix. + *--------------------------------------------------------------------------- + */ + #include <errno.h> #include <fcntl.h> #ifdef HAVE_NET_ERRNO_H @@ -35,16 +43,18 @@ #endif #include <pwd.h> #include <signal.h> -#include <sys/param.h> +#ifdef HAVE_SYS_PARAM_H +# include <sys/param.h> +#endif #include <sys/types.h> #ifdef USE_DIRENT2_H # include "../compat/dirent2.h" #else -# ifdef NO_DIRENT_H -# include "../compat/dirent.h" -# else -# include <dirent.h> -# endif +#ifdef NO_DIRENT_H +# include "../compat/dirent.h" +#else +# include <dirent.h> +#endif #endif #include <sys/file.h> #ifdef HAVE_SYS_SELECT_H @@ -55,11 +65,11 @@ # include <sys/time.h> # include <time.h> #else -# if HAVE_SYS_TIME_H -# include <sys/time.h> -# else -# include <time.h> -# endif +#if HAVE_SYS_TIME_H +# include <sys/time.h> +#else +# include <time.h> +#endif #endif #ifndef NO_SYS_WAIT_H # include <sys/wait.h> @@ -70,7 +80,6 @@ # include "../compat/unistd.h" #endif #ifdef USE_FIONBIO - /* * Not using the Posix fcntl(...,O_NONBLOCK,...) interface, instead * we are using ioctl(..,FIONBIO,..). @@ -105,11 +114,11 @@ */ #ifndef NO_FLOAT_H -#include <float.h> +# include <float.h> #else -# ifndef NO_VALUES_H -# include <values.h> -# endif +#ifndef NO_VALUES_H +# include <values.h> +#endif #endif #ifndef FLT_MAX @@ -148,20 +157,6 @@ #endif /* - * The default platform eol translation on Unix is TCL_TRANSLATE_LF: - */ - -#define TCL_PLATFORM_TRANSLATION TCL_TRANSLATE_LF - -/* - * Not all systems declare the errno variable in errno.h. so this - * file does it explicitly. The list of system error messages also - * isn't generally declared in a header file anywhere. - */ - -extern int errno; - -/* * The type of the status returned by wait varies from UNIX system * to UNIX system. The macro below defines it: */ @@ -225,21 +220,18 @@ extern int errno; #ifndef SEEK_SET # define SEEK_SET 0 #endif - #ifndef SEEK_CUR # define SEEK_CUR 1 #endif - #ifndef SEEK_END # define SEEK_END 2 #endif /* - * The stuff below is needed by the "time" command. If this - * system has no gettimeofday call, then must use times and the - * CLK_TCK #define (from sys/param.h) to compute elapsed time. - * Unfortunately, some systems only have HZ and no CLK_TCK, and - * some might not even have HZ. + * The stuff below is needed by the "time" command. If this system has no + * gettimeofday call, then must use times and the CLK_TCK #define (from + * sys/param.h) to compute elapsed time. Unfortunately, some systems only + * have HZ and no CLK_TCK, and some might not even have HZ. */ #ifdef NO_GETTOD @@ -295,7 +287,7 @@ EXTERN int gettimeofday _ANSI_ARGS_((struct timeval *tp, */ #ifndef S_IFLNK -# define lstat stat +# define lstat stat #endif /* @@ -419,16 +411,19 @@ EXTERN int gettimeofday _ANSI_ARGS_((struct timeval *tp, #define MASK_SIZE howmany(FD_SETSIZE, NFDBITS) /* - * The following implements the Unix method for exiting the process. + * Not all systems declare the errno variable in errno.h. so this + * file does it explicitly. The list of system error messages also + * isn't generally declared in a header file anywhere. */ -#define TclPlatformExit(status) exit(status) + +extern int errno; /* * Variables provided by the C library: */ #if defined(_sgi) || defined(__sgi) -#define environ _environ +# define environ _environ #endif extern char **environ; @@ -443,20 +438,63 @@ extern char **environ; extern double strtod(); /* - * The following macros define time related functions in terms of - * standard Unix routines. + *--------------------------------------------------------------------------- + * The following macros and declarations represent the interface between + * generic and unix-specific parts of Tcl. Some of the macros may override + * functions declared in tclInt.h. + *--------------------------------------------------------------------------- */ -#define TclpGetPid(pid) ((unsigned long) (pid)) +/* + * The default platform eol translation on Unix is TCL_TRANSLATE_LF. + */ -#define TclpReleaseFile(file) +#define TCL_PLATFORM_TRANSLATION TCL_TRANSLATE_LF /* - * The following defines stub out functions that aren't needed on Unix. + * The following macros have trivial definitions, allowing generic code to + * address platform-specific issues. */ -#define TclpFinalize() #define TclpAsyncMark(async) +#define TclpGetPid(pid) ((unsigned long) (pid)) +#define TclpReleaseFile(file) /* Nothing. */ + +/* + * The following macros and declaration wrap the C runtime library + * functions. + */ + +#define TclpExit exit + +#ifdef TclpStat +#undef TclpStat +#endif + +EXTERN int TclpLstat _ANSI_ARGS_((CONST char *path, + struct stat *buf)); +EXTERN int TclpStat _ANSI_ARGS_((CONST char *path, + struct stat *buf)); + +/* + * Platform specific mutex definition used by memory allocators. + * These mutexes are statically allocated and explicitly initialized. + * Most modules do not use this, but instead use Tcl_Mutex types and + * Tcl_MutexLock and Tcl_MutexUnlock that are self-initializing. + */ + +#ifdef TCL_THREADS +#include <pthread.h> +typedef pthread_mutex_t TclpMutex; +EXTERN void TclpMutexInit _ANSI_ARGS_((TclpMutex *mPtr)); +EXTERN void TclpMutexLock _ANSI_ARGS_((TclpMutex *mPtr)); +EXTERN void TclpMutexUnlock _ANSI_ARGS_((TclpMutex *mPtr)); +#else +typedef int TclpMutex; +#define TclpMutexInit(a) +#define TclpMutexLock(a) +#define TclpMutexUnlock(a) +#endif /* TCL_THREADS */ #include "tclPlatDecls.h" #include "tclIntPlatDecls.h" diff --git a/unix/tclUnixSock.c b/unix/tclUnixSock.c index 2013e8f..37d430e 100644 --- a/unix/tclUnixSock.c +++ b/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. * - * RCS: @(#) $Id: tclUnixSock.c,v 1.3 1999/03/10 05:52:52 stanton Exp $ + * RCS: @(#) $Id: tclUnixSock.c,v 1.4 1999/04/16 00:48:05 stanton Exp $ */ #include "tcl.h" @@ -41,6 +41,8 @@ static char hostname[TCL_HOSTNAME_LEN + 1]; static int hostnameInited = 0; +TCL_DECLARE_MUTEX(hostMutex) + /* *---------------------------------------------------------------------- @@ -66,43 +68,53 @@ Tcl_GetHostName() #ifndef NO_UNAME struct utsname u; struct hostent *hp; +#else + char buffer[sizeof(hostname)]; #endif + CONST char *native; + Tcl_MutexLock(&hostMutex); if (hostnameInited) { + Tcl_MutexUnlock(&hostMutex); return hostname; } + native = NULL; #ifndef NO_UNAME (VOID *) memset((VOID *) &u, (int) 0, sizeof(struct utsname)); - if (uname(&u) > -1) { - hp = gethostbyname(u.nodename); + if (uname(&u) > -1) { /* INTL: Native. */ + hp = gethostbyname(u.nodename); /* INTL: Native. */ if (hp != NULL) { - strcpy(hostname, hp->h_name); + native = hp->h_name; } else { - strcpy(hostname, u.nodename); + native = u.nodename; } - hostnameInited = 1; - return hostname; } #else /* * Uname doesn't exist; try gethostname instead. */ - if (gethostname(hostname, sizeof(hostname)) > -1) { - hostnameInited = 1; - return hostname; + if (gethostname(buffer, sizeof(buffer)) > -1) { /* INTL: Native. */ + native = buffer; } #endif - hostname[0] = 0; + if (native == NULL) { + hostname[0] = 0; + } else { + Tcl_ExternalToUtf(NULL, NULL, native, -1, 0, NULL, hostname, + sizeof(hostname), NULL, NULL, NULL); + } + hostnameInited = 1; + Tcl_MutexUnlock(&hostMutex); return hostname; } /* *---------------------------------------------------------------------- * - * TclHasSockets -- + * TclpHasSockets -- * * Detect if sockets are available on this platform. * @@ -116,7 +128,7 @@ Tcl_GetHostName() */ int -TclHasSockets(interp) +TclpHasSockets(interp) Tcl_Interp *interp; /* Not used. */ { return TCL_OK; diff --git a/unix/tclUnixTest.c b/unix/tclUnixTest.c index a8b48ea..7c7559b 100644 --- a/unix/tclUnixTest.c +++ b/unix/tclUnixTest.c @@ -3,13 +3,13 @@ * * Contains platform specific test commands for the Unix platform. * - * Copyright (c) 1996 Sun Microsystems, Inc. + * Copyright (c) 1996-1997 Sun Microsystems, Inc. * Copyright (c) 1998 by Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclUnixTest.c,v 1.9 1998/10/14 00:32:55 rjohnson Exp $ + * RCS: @(#) $Id: tclUnixTest.c,v 1.10 1999/04/16 00:48:05 stanton Exp $ */ #include "tclInt.h" @@ -73,6 +73,10 @@ static int TestfindexecutableCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int argc, char **argv)); static int TestgetopenfileCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int argc, char **argv)); +static int TestgetdefencdirCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestsetdefencdirCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); int TclplatformtestInit _ANSI_ARGS_((Tcl_Interp *interp)); static int TestalarmCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int argc, char **argv)); @@ -109,6 +113,10 @@ TclplatformtestInit(interp) (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateCommand(interp, "testgetopenfile", TestgetopenfileCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testgetdefenc", TestgetdefencdirCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testsetdefenc", TestsetdefencdirCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateCommand(interp, "testalarm", TestalarmCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateCommand(interp, "testgotsig", TestgotsigCmd, @@ -193,7 +201,7 @@ TestfilehandlerCmd(clientData, interp, argc, argv) } pipePtr->readCount = pipePtr->writeCount = 0; } else if (strcmp(argv[1], "counts") == 0) { - char buf[30]; + char buf[TCL_INTEGER_SPACE * 2]; if (argc != 3) { Tcl_AppendResult(interp, "wrong # arguments: should be \"", @@ -275,7 +283,7 @@ TestfilehandlerCmd(clientData, interp, argc, argv) /* Empty loop body. */ } } else if (strcmp(argv[1], "fillpartial") == 0) { - char buf[30]; + char buf[TCL_INTEGER_SPACE]; if (argc != 3) { Tcl_AppendResult(interp, "wrong # arguments: should be \"", @@ -284,7 +292,7 @@ TestfilehandlerCmd(clientData, interp, argc, argv) } memset((VOID *) buffer, 'b', 10); - sprintf(buf, "%d", write(GetFd(pipePtr->writeFile), buffer, 10)); + TclFormatInt(buf, write(GetFd(pipePtr->writeFile), buffer, 10)); Tcl_SetResult(interp, buf, TCL_VOLATILE); } else if (strcmp(argv[1], "oneevent") == 0) { Tcl_DoOneEvent(TCL_FILE_EVENTS|TCL_DONT_WAIT); @@ -438,20 +446,29 @@ TestfindexecutableCmd(clientData, interp, argc, argv) char **argv; /* Argument strings. */ { char *oldName; + char *oldNativeName; if (argc != 2) { Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], " argv0\"", (char *) NULL); return TCL_ERROR; } - oldName = tclExecutableName; - tclExecutableName = NULL; + + oldName = tclExecutableName; + oldNativeName = tclNativeExecutableName; + + tclExecutableName = NULL; + tclNativeExecutableName = NULL; + Tcl_FindExecutable(argv[1]); if (tclExecutableName != NULL) { Tcl_SetResult(interp, tclExecutableName, TCL_VOLATILE); ckfree(tclExecutableName); } - tclExecutableName = oldName; + + tclExecutableName = oldName; + tclNativeExecutableName = oldNativeName; + return TCL_OK; } @@ -502,6 +519,87 @@ TestgetopenfileCmd(clientData, interp, argc, argv) /* *---------------------------------------------------------------------- + * + * TestsetdefencdirCmd -- + * + * This procedure implements the "testsetdefenc" command. It is + * used to set the value of tclDefaultEncodingDir. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TestsetdefencdirCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + if (argc != 2) { + Tcl_AppendResult(interp, + "wrong # args: should be \"", argv[0], + " defaultDir\"", + (char *) NULL); + return TCL_ERROR; + } + + if (tclDefaultEncodingDir != NULL) { + ckfree(tclDefaultEncodingDir); + tclDefaultEncodingDir = NULL; + } + if (*argv[1] != '\0') { + tclDefaultEncodingDir = (char *) + ckalloc((unsigned) strlen(argv[1]) + 1); + strcpy(tclDefaultEncodingDir, argv[1]); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TestgetdefencdirCmd -- + * + * This procedure implements the "testgetdefenc" command. It is + * used to get the value of tclDefaultEncodingDir. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TestgetdefencdirCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + if (argc != 1) { + Tcl_AppendResult(interp, + "wrong # args: should be \"", argv[0], + (char *) NULL); + return TCL_ERROR; + } + + if (tclDefaultEncodingDir != NULL) { + Tcl_AppendResult(interp, tclDefaultEncodingDir, (char *) NULL); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- * TestalarmCmd -- * * Test that EINTR is handled correctly by generating and diff --git a/unix/tclUnixThrd.c b/unix/tclUnixThrd.c new file mode 100644 index 0000000..b00bf42 --- /dev/null +++ b/unix/tclUnixThrd.c @@ -0,0 +1,682 @@ +/* + * tclUnixThrd.c -- + * + * This file implements the UNIX-specific thread support. + * + * Copyright (c) 1991-1994 The Regents of the University of California. + * Copyright (c) 1994-1997 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclUnixThrd.c 1.18 98/02/19 14:24:12 + */ + +#include "tclInt.h" + +#ifdef TCL_THREADS + +#include "tclPort.h" +#include "pthread.h" + +/* + * masterLock is used to serialize creation of mutexes, condition + * variables, and thread local storage. + * This is the only place that can count on the ability to statically + * initialize the mutex. + */ + +static pthread_mutex_t masterLock = PTHREAD_MUTEX_INITIALIZER; + +/* + * initLock is used to serialize initialization and finalization + * of Tcl. It cannot use any dyamically allocated storage. + */ + +static pthread_mutex_t initLock = PTHREAD_MUTEX_INITIALIZER; + +/* + * These are for the critical sections inside this file. + */ + +#define MASTER_LOCK pthread_mutex_lock(&masterLock) +#define MASTER_UNLOCK pthread_mutex_unlock(&masterLock) + +#endif /* TCL_THREADS */ + + + +#ifdef TCL_THREADS + +/* + *---------------------------------------------------------------------- + * + * TclpThreadCreate -- + * + * This procedure creates a new thread. + * + * Results: + * TCL_OK if the thread could be created. The thread ID is + * returned in a parameter. + * + * Side effects: + * A new thread is created. + * + *---------------------------------------------------------------------- + */ + +int +TclpThreadCreate(idPtr, proc, clientData) + Tcl_ThreadId *idPtr; /* Return, the ID of the thread */ + Tcl_ThreadCreateProc proc; /* Main() function of the thread */ + ClientData clientData; /* The one argument to Main() */ +{ + pthread_attr_t attr; + + pthread_attr_init(&attr); + pthread_attr_setscope(&attr, PTHREAD_SCOPE_SYSTEM); + if (pthread_create((pthread_t *)idPtr, &attr, (void * (*)())proc, (void *)clientData) < 0) { + return TCL_ERROR; + } else { + return TCL_OK; + } +} + +/* + *---------------------------------------------------------------------- + * + * TclpThreadExit -- + * + * This procedure terminates the current thread. + * + * Results: + * None. + * + * Side effects: + * This procedure terminates the current thread. + * + *---------------------------------------------------------------------- + */ + +void +TclpThreadExit(status) + int status; +{ + pthread_exit((VOID *)status); +} +#endif /* TCL_THREADS */ + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetCurrentThread -- + * + * This procedure returns the ID of the currently running thread. + * + * Results: + * A thread ID. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_ThreadId +Tcl_GetCurrentThread() +{ +#ifdef TCL_THREADS + return (Tcl_ThreadId) pthread_self(); +#else + return (Tcl_ThreadId) 0; +#endif +} + + +/* + *---------------------------------------------------------------------- + * + * TclpInitLock + * + * This procedure is used to grab a lock that serializes initialization + * and finalization of Tcl. On some platforms this may also initialize + * the mutex used to serialize creation of more mutexes and thread + * local storage keys. + * + * Results: + * None. + * + * Side effects: + * Acquire the initialization mutex. + * + *---------------------------------------------------------------------- + */ + +void +TclpInitLock() +{ +#ifdef TCL_THREADS + pthread_mutex_lock(&initLock); +#endif +} + + +/* + *---------------------------------------------------------------------- + * + * TclpInitUnlock + * + * This procedure is used to release a lock that serializes initialization + * and finalization of Tcl. + * + * Results: + * None. + * + * Side effects: + * Release the initialization mutex. + * + *---------------------------------------------------------------------- + */ + +void +TclpInitUnlock() +{ +#ifdef TCL_THREADS + pthread_mutex_unlock(&initLock); +#endif +} + +/* + *---------------------------------------------------------------------- + * + * TclpMasterLock + * + * This procedure is used to grab a lock that serializes creation + * and finalization of serialization objects. This interface is + * only needed in finalization; it is hidden during + * creation of the objects. + * + * This lock must be different than the initLock because the + * initLock is held during creation of syncronization objects. + * + * Results: + * None. + * + * Side effects: + * Acquire the master mutex. + * + *---------------------------------------------------------------------- + */ + +void +TclpMasterLock() +{ +#ifdef TCL_THREADS + pthread_mutex_lock(&masterLock); +#endif +} + + +/* + *---------------------------------------------------------------------- + * + * TclpMasterUnlock + * + * This procedure is used to release a lock that serializes creation + * and finalization of synchronization objects. + * + * Results: + * None. + * + * Side effects: + * Release the master mutex. + * + *---------------------------------------------------------------------- + */ + +void +TclpMasterUnlock() +{ +#ifdef TCL_THREADS + pthread_mutex_unlock(&masterLock); +#endif +} + +#ifdef TCL_THREADS + +/* + *---------------------------------------------------------------------- + * + * TclpMutexInit -- + * TclpMutexLock -- + * TclpMutexUnlock -- + * + * These procedures use an explicitly initialized mutex. + * These are used by memory allocators for their own mutex. + * + * Results: + * None. + * + * Side effects: + * Initialize, Lock, and Unlock the mutex. + * + *---------------------------------------------------------------------- + */ + +void +TclpMutexInit(mPtr) + TclpMutex *mPtr; +{ + pthread_mutex_init((pthread_mutex_t *)mPtr, NULL); +} +void +TclpMutexLock(mPtr) + TclpMutex *mPtr; +{ + pthread_mutex_lock((pthread_mutex_t *)mPtr); +} +void +TclpMutexUnlock(mPtr) + TclpMutex *mPtr; +{ + pthread_mutex_unlock((pthread_mutex_t *)mPtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_MutexLock -- + * + * This procedure is invoked to lock a mutex. This procedure + * handles initializing the mutex, if necessary. The caller + * can rely on the fact that Tcl_Mutex is an opaque pointer. + * This routine will change that pointer from NULL after first use. + * + * Results: + * None. + * + * Side effects: + * May block the current thread. The mutex is aquired when + * this returns. Will allocate memory for a pthread_mutex_t + * and initialize this the first time this Tcl_Mutex is used. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_MutexLock(mutexPtr) + Tcl_Mutex *mutexPtr; /* Really (pthread_mutex_t **) */ +{ + pthread_mutex_t *pmutexPtr; + if (*mutexPtr == NULL) { + MASTER_LOCK; + if (*mutexPtr == NULL) { + /* + * Double inside master lock check to avoid a race. + */ + + pmutexPtr = (pthread_mutex_t *)ckalloc(sizeof(pthread_mutex_t)); + pthread_mutex_init(pmutexPtr, NULL); + *mutexPtr = (Tcl_Mutex)pmutexPtr; + TclRememberMutex(mutexPtr); + } + MASTER_UNLOCK; + } + pmutexPtr = *((pthread_mutex_t **)mutexPtr); + pthread_mutex_lock(pmutexPtr); +} + + +/* + *---------------------------------------------------------------------- + * + * TclpMutexUnlock -- + * + * This procedure is invoked to unlock a mutex. The mutex must + * have been locked by Tcl_MutexLock. + * + * Results: + * None. + * + * Side effects: + * The mutex is released when this returns. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_MutexUnlock(mutexPtr) + Tcl_Mutex *mutexPtr; /* Really (pthread_mutex_t **) */ +{ + pthread_mutex_t *pmutexPtr = *(pthread_mutex_t **)mutexPtr; + pthread_mutex_unlock(pmutexPtr); +} + + +/* + *---------------------------------------------------------------------- + * + * TclpFinalizeMutex -- + * + * This procedure is invoked to clean up one mutex. This is only + * safe to call at the end of time. + * + * This assumes the Master Lock is held. + * + * Results: + * None. + * + * Side effects: + * The mutex list is deallocated. + * + *---------------------------------------------------------------------- + */ + +void +TclpFinalizeMutex(mutexPtr) + Tcl_Mutex *mutexPtr; +{ + pthread_mutex_t *pmutexPtr = *(pthread_mutex_t **)mutexPtr; + if (pmutexPtr != NULL) { + ckfree((char *)pmutexPtr); + *mutexPtr = NULL; + } +} + + +/* + *---------------------------------------------------------------------- + * + * TclpThreadDataKeyInit -- + * + * This procedure initializes a thread specific data block key. + * Each thread has table of pointers to thread specific data. + * all threads agree on which table entry is used by each module. + * this is remembered in a "data key", that is just an index into + * this table. To allow self initialization, the interface + * passes a pointer to this key and the first thread to use + * the key fills in the pointer to the key. The key should be + * a process-wide static. + * + * Results: + * None. + * + * Side effects: + * Will allocate memory the first time this process calls for + * this key. In this case it modifies its argument + * to hold the pointer to information about the key. + * + *---------------------------------------------------------------------- + */ + +void +TclpThreadDataKeyInit(keyPtr) + Tcl_ThreadDataKey *keyPtr; /* Identifier for the data chunk, + * really (pthread_key_t **) */ +{ + pthread_key_t *pkeyPtr; + + MASTER_LOCK; + if (*keyPtr == NULL) { + pkeyPtr = (pthread_key_t *)ckalloc(sizeof(pthread_key_t)); + pthread_key_create(pkeyPtr, NULL); + *keyPtr = (Tcl_ThreadDataKey)pkeyPtr; + TclRememberDataKey(keyPtr); + } + MASTER_UNLOCK; +} + +/* + *---------------------------------------------------------------------- + * + * TclpThreadDataKeyGet -- + * + * This procedure returns a pointer to a block of thread local storage. + * + * Results: + * A thread-specific pointer to the data structure, or NULL + * if the memory has not been assigned to this key for this thread. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +VOID * +TclpThreadDataKeyGet(keyPtr) + Tcl_ThreadDataKey *keyPtr; /* Identifier for the data chunk, + * really (pthread_key_t **) */ +{ + pthread_key_t *pkeyPtr = *(pthread_key_t **)keyPtr; + if (pkeyPtr == NULL) { + return NULL; + } else { + return (VOID *)pthread_getspecific(*pkeyPtr); + } +} + + +/* + *---------------------------------------------------------------------- + * + * TclpThreadDataKeySet -- + * + * This procedure sets the pointer to a block of thread local storage. + * + * Results: + * None. + * + * Side effects: + * Sets up the thread so future calls to TclpThreadDataKeyGet with + * this key will return the data pointer. + * + *---------------------------------------------------------------------- + */ + +void +TclpThreadDataKeySet(keyPtr, data) + Tcl_ThreadDataKey *keyPtr; /* Identifier for the data chunk, + * really (pthread_key_t **) */ + VOID *data; /* Thread local storage */ +{ + pthread_key_t *pkeyPtr = *(pthread_key_t **)keyPtr; + pthread_setspecific(*pkeyPtr, data); +} + +/* + *---------------------------------------------------------------------- + * + * TclpFinalizeThreadData -- + * + * This procedure cleans up the thread-local storage. This is + * called once for each thread. + * + * Results: + * None. + * + * Side effects: + * Frees up all thread local storage. + * + *---------------------------------------------------------------------- + */ + +void +TclpFinalizeThreadData(keyPtr) + Tcl_ThreadDataKey *keyPtr; +{ + VOID *result; + pthread_key_t *pkeyPtr; + + if (*keyPtr != NULL) { + pkeyPtr = *(pthread_key_t **)keyPtr; + result = (VOID *)pthread_getspecific(*pkeyPtr); + if (result != NULL) { + ckfree((char *)result); + pthread_setspecific(*pkeyPtr, (void *)NULL); + } + } +} + +/* + *---------------------------------------------------------------------- + * + * TclpFinalizeThreadDataKey -- + * + * This procedure is invoked to clean up one key. This is a + * process-wide storage identifier. The thread finalization code + * cleans up the thread local storage itself. + * + * This assumes the master lock is held. + * + * Results: + * None. + * + * Side effects: + * The key is deallocated. + * + *---------------------------------------------------------------------- + */ + +void +TclpFinalizeThreadDataKey(keyPtr) + Tcl_ThreadDataKey *keyPtr; +{ + pthread_key_t *pkeyPtr; + if (*keyPtr != NULL) { + pkeyPtr = *(pthread_key_t **)keyPtr; + pthread_key_delete(*pkeyPtr); + ckfree((char *)pkeyPtr); + *keyPtr = NULL; + } +} + + +/* + *---------------------------------------------------------------------- + * + * Tcl_ConditionWait -- + * + * This procedure is invoked to wait on a condition variable. + * The mutex is automically released as part of the wait, and + * automatically grabbed when the condition is signaled. + * + * The mutex must be held when this procedure is called. + * + * Results: + * None. + * + * Side effects: + * May block the current thread. The mutex is aquired when + * this returns. Will allocate memory for a pthread_mutex_t + * and initialize this the first time this Tcl_Mutex is used. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_ConditionWait(condPtr, mutexPtr, timePtr) + Tcl_Condition *condPtr; /* Really (pthread_cond_t **) */ + Tcl_Mutex *mutexPtr; /* Really (pthread_mutex_t **) */ + Tcl_Time *timePtr; /* Timeout on waiting period */ +{ + pthread_cond_t *pcondPtr; + pthread_mutex_t *pmutexPtr; + struct timespec ptime; + + if (*condPtr == NULL) { + MASTER_LOCK; + + /* + * Double check inside mutex to avoid race, + * then initialize condition variable if necessary. + */ + + if (*condPtr == NULL) { + pcondPtr = (pthread_cond_t *)ckalloc(sizeof(pthread_cond_t)); + pthread_cond_init(pcondPtr, NULL); + *condPtr = (Tcl_Condition)pcondPtr; + TclRememberCondition(condPtr); + } + MASTER_UNLOCK; + } + pmutexPtr = *((pthread_mutex_t **)mutexPtr); + pcondPtr = *((pthread_cond_t **)condPtr); + if (timePtr == NULL) { + pthread_cond_wait(pcondPtr, pmutexPtr); + } else { + ptime.tv_sec = timePtr->sec + TclpGetSeconds(); + ptime.tv_nsec = 1000 * timePtr->usec; + pthread_cond_timedwait(pcondPtr, pmutexPtr, &ptime); + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ConditionNotify -- + * + * This procedure is invoked to signal a condition variable. + * + * The mutex must be held during this call to avoid races, + * but this interface does not enforce that. + * + * Results: + * None. + * + * Side effects: + * May unblock another thread. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_ConditionNotify(condPtr) + Tcl_Condition *condPtr; +{ + pthread_cond_t *pcondPtr = *((pthread_cond_t **)condPtr); + if (pcondPtr != NULL) { + pthread_cond_broadcast(pcondPtr); + } else { + /* + * Noone has used the condition variable, so there are no waiters. + */ + } +} + + +/* + *---------------------------------------------------------------------- + * + * TclpFinalizeCondition -- + * + * This procedure is invoked to clean up a condition variable. + * This is only safe to call at the end of time. + * + * This assumes the Master Lock is held. + * + * Results: + * None. + * + * Side effects: + * The condition variable is deallocated. + * + *---------------------------------------------------------------------- + */ + +void +TclpFinalizeCondition(condPtr) + Tcl_Condition *condPtr; +{ + pthread_cond_t *pcondPtr = *(pthread_cond_t **)condPtr; + if (pcondPtr != NULL) { + pthread_cond_destroy(pcondPtr); + ckfree((char *)pcondPtr); + *condPtr = NULL; + } +} + + + +#endif /* TCL_THREADS */ + diff --git a/unix/tclUnixThrd.h b/unix/tclUnixThrd.h new file mode 100644 index 0000000..a4f6fc6 --- /dev/null +++ b/unix/tclUnixThrd.h @@ -0,0 +1,21 @@ +/* + * tclUnixThrd.h -- + * + * This header file defines things for thread support. + * + * Copyright (c) 1998 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) + */ + +#ifndef _TCLUNIXTHRD +#define _TCLUNIXTHRD + +#ifdef TCL_THREADS + + +#endif /* TCL_THREADS */ +#endif /* _TCLUNIXTHRD */ diff --git a/unix/tclUnixTime.c b/unix/tclUnixTime.c index 02a1570..9427999 100644 --- a/unix/tclUnixTime.c +++ b/unix/tclUnixTime.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. * - * RCS: @(#) $Id: tclUnixTime.c,v 1.3 1999/03/10 05:52:53 stanton Exp $ + * RCS: @(#) $Id: tclUnixTime.c,v 1.4 1999/04/16 00:48:06 stanton Exp $ */ #include "tclInt.h" @@ -165,12 +165,17 @@ TclpGetTimeZone (currentTime) #if defined(HAVE_TIMEZONE_VAR) && !defined (TCL_GOT_TIMEZONE) # define TCL_GOT_TIMEZONE static int setTZ = 0; +#ifdef TCL_THREADS + static Tcl_Mutex tzMutex; +#endif int timeZone; + Tcl_MutexLock(&tzMutex); if (!setTZ) { tzset(); setTZ = 1; } + Tcl_MutexUnlock(&tzMutex); /* * Note: this is not a typo in "timezone" below! See tzset @@ -258,7 +263,7 @@ TclpGetDate(time, useGMT) TclpTime_t time; int useGMT; { - const time_t *tp = (const time_t *)time; + CONST time_t *tp = (CONST time_t *)time; if (useGMT) { return gmtime(tp); @@ -270,7 +275,7 @@ TclpGetDate(time, useGMT) /* *---------------------------------------------------------------------- * - * TclStrftime -- + * TclpStrftime -- * * On Unix, we can safely call the native strftime implementation. * @@ -284,11 +289,11 @@ TclpGetDate(time, useGMT) */ size_t -TclStrftime(s, maxsize, format, t) +TclpStrftime(s, maxsize, format, t) char *s; size_t maxsize; - const char *format; - const struct tm *t; + CONST char *format; + CONST struct tm *t; { return strftime(s, maxsize, format, t); } diff --git a/unix/tclXtTest.c b/unix/tclXtTest.c index 77c3a17..da45a57 100644 --- a/unix/tclXtTest.c +++ b/unix/tclXtTest.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. * - * RCS: @(#) $Id: tclXtTest.c,v 1.2 1998/09/14 18:40:18 stanton Exp $ + * RCS: @(#) $Id: tclXtTest.c,v 1.3 1999/04/16 00:48:06 stanton Exp $ */ #include <X11/Intrinsic.h> @@ -28,7 +28,7 @@ static int TesteventloopCmd _ANSI_ARGS_((ClientData clientData, * * Results: * Returns a standard Tcl completion code, and leaves an error - * message in interp->result if an error occurs. + * message in the interp's result if an error occurs. * * Side effects: * Depends on the startup script. |