diff options
Diffstat (limited to 'unix')
| -rw-r--r-- | unix/Makefile.in | 148 | ||||
| -rw-r--r-- | unix/README | 10 | ||||
| -rw-r--r-- | unix/configure.in | 51 | ||||
| -rw-r--r-- | unix/dltest/pkge.c | 5 | ||||
| -rw-r--r-- | unix/mkLinks | 266 | ||||
| -rw-r--r-- | unix/tclAppInit.c | 28 | ||||
| -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 | 529 | ||||
| -rw-r--r-- | unix/tclUnixEvent.c | 4 | ||||
| -rw-r--r-- | unix/tclUnixFCmd.c | 705 | ||||
| -rw-r--r-- | unix/tclUnixFile.c | 601 | ||||
| -rw-r--r-- | unix/tclUnixInit.c | 489 | ||||
| -rw-r--r-- | unix/tclUnixNotfy.c | 592 | ||||
| -rw-r--r-- | unix/tclUnixPipe.c | 103 | ||||
| -rw-r--r-- | unix/tclUnixPort.h | 153 | ||||
| -rw-r--r-- | unix/tclUnixSock.c | 34 | ||||
| -rw-r--r-- | unix/tclUnixTest.c | 10 | ||||
| -rw-r--r-- | unix/tclUnixThrd.c | 717 | ||||
| -rw-r--r-- | unix/tclUnixThrd.h | 21 | ||||
| -rw-r--r-- | unix/tclUnixTime.c | 5 | ||||
| -rw-r--r-- | unix/tclXtTest.c | 4 |
28 files changed, 3611 insertions, 1221 deletions
diff --git a/unix/Makefile.in b/unix/Makefile.in index 6b15ff5..e5d440f 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. # -# SCCS: @(#) Makefile.in 1.190 97/11/05 10:57:38 +# SCCS: @(#) Makefile.in 1.214 98/02/23 17:10:26 # Current Tcl version; used in various names. @@ -106,7 +106,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 = @@ -124,6 +124,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 @@ -183,8 +188,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@ #---------------------------------------------------------------- @@ -196,7 +205,8 @@ CC = @CC@ CC_SWITCHES = ${CFLAGS} ${TCL_SHLIB_CFLAGS} -I${GENERIC_DIR} -I${SRC_DIR} \ ${AC_FLAGS} ${MATH_FLAGS} ${GENERIC_FLAGS} ${PROTO_FLAGS} ${MEM_DEBUG_FLAGS} \ -${COMPILE_DEBUG_FLAGS} ${ENV_FLAGS} -DTCL_SHLIB_EXT=\"${SHLIB_SUFFIX}\" +${COMPILE_DEBUG_FLAGS} ${NO_DEPRECATED_FLAGS} ${ENV_FLAGS} \ +-DTCL_SHLIB_EXT=\"${SHLIB_SUFFIX}\" LIBS = @DL_LIBS@ @LIBS@ $(MATH_LIBS) -lc @@ -207,19 +217,24 @@ ${GENERIC_FLAGS} ${PROTO_FLAGS} ${MEM_DEBUG_FLAGS} \ TCLSH_OBJS = tclAppInit.o -TCLTEST_OBJS = tclTestInit.o tclTest.o tclTestObj.o tclUnixTest.o +TCLTEST_OBJS = tclTestInit.o tclTest.o tclTestObj.o tclUnixTest.o \ + tclThreadTest.o XTTEST_OBJS = tclTest.o tclTestObj.o tclUnixTest.o tclXtNotify.o \ tclXtTest.o xtTestInit.o -GENERIC_OBJS = panic.o regexp.o tclAsync.o tclBasic.o tclBinary.o tclCkalloc.o \ - tclClock.o tclCmdAH.o tclCmdIL.o tclCmdMZ.o tclCompExpr.o \ - tclCompile.o tclDate.o tclEnv.o tclEvent.o tclExecute.o \ - tclFCmd.o tclFileName.o tclGet.o tclHash.o tclHistory.o \ - tclIndexObj.o tclInterp.o tclIO.o tclIOCmd.o tclIOSock.o \ - tclIOUtil.o tclLink.o tclListObj.o tclLoad.o tclMain.o tclNamesp.o \ - tclNotify.o tclObj.o tclParse.o tclPipe.o tclPkg.o tclPosixStr.o \ - tclPreserve.o tclProc.o tclStringObj.o tclTimer.o tclUtil.o tclVar.o +GENERIC_OBJS = compile.o exec.o panic.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 tclParse.o tclParseExpr.o tclPipe.o \ + tclPkg.o tclPosixStr.o tclPreserve.o tclProc.o tclRegexp.o \ + tclResult.o tclStringObj.o tclThread.o tclTimer.o tclUtf.o tclUtil.o \ + tclVar.o OBJS = ${GENERIC_OBJS} ${UNIX_OBJS} ${NOTIFY_OBJS} ${COMPAT_OBJS} @DL_OBJS@ @@ -231,7 +246,8 @@ GENERIC_HDRS = \ $(GENERIC_DIR)/tclPatch.h GENERIC_SRCS = \ - $(GENERIC_DIR)/regexp.c \ + $(GENERIC_DIR)/compile.c \ + $(GENERIC_DIR)/exec.c \ $(GENERIC_DIR)/tclAsync.c \ $(GENERIC_DIR)/tclBasic.c \ $(GENERIC_DIR)/tclBinary.c \ @@ -240,9 +256,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 \ @@ -259,20 +277,25 @@ 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)/tclResult.c \ $(GENERIC_DIR)/tclStringObj.c \ $(GENERIC_DIR)/tclTest.c \ $(GENERIC_DIR)/tclTestObj.c \ + $(GENERIC_DIR)/tclThread.c \ $(GENERIC_DIR)/tclTimer.c \ $(GENERIC_DIR)/tclUtil.c \ $(GENERIC_DIR)/tclVar.c @@ -291,6 +314,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 @@ -352,13 +376,13 @@ xttest: ${XTTEST_OBJS} ${GENERIC_OBJS} ${UNIX_OBJS} ${COMPAT_OBJS} \ test: tcltest LD_LIBRARY_PATH=`pwd`:${LD_LIBRARY_PATH}; export LD_LIBRARY_PATH; \ - TCL_LIBRARY=${TOP_DIR}/library; export TCL_LIBRARY; \ + TCL_LIBRARY="${TCL_BUILDTIME_LIBRARY}"; export TCL_LIBRARY; \ ( echo cd $(TOP_DIR)/tests\; source all ) | ./tcltest # Useful target to launch a built tcltest with the proper path,... runtest: LD_LIBRARY_PATH=`pwd`:${LD_LIBRARY_PATH}; export LD_LIBRARY_PATH; \ - TCL_LIBRARY=${TOP_DIR}/library; export TCL_LIBRARY; \ + TCL_LIBRARY="${TCL_BUILDTIME_LIBRARY}"; export TCL_LIBRARY; \ ./tcltest # The following target outputs the name of the top-level source directory @@ -440,7 +464,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; \ do \ if [ ! -d $(SCRIPT_INSTALL_DIR)/$$i ] ; then \ echo "Making directory $(SCRIPT_INSTALL_DIR)/$$i"; \ @@ -456,7 +480,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; \ do \ for j in $(TOP_DIR)/library/$$i/*.tcl ; \ do \ @@ -464,6 +488,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) ; \ @@ -532,7 +560,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 \ @@ -557,8 +587,11 @@ xtTestInit.o: $(UNIX_DIR)/tclAppInit.c panic.o: $(GENERIC_DIR)/panic.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/panic.c -regexp.o: $(GENERIC_DIR)/regexp.c - $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/regexp.c +compile.o: $(GENERIC_DIR)/compile.c $(GENERIC_DIR)/lex.c $(GENERIC_DIR)/color.c $(GENERIC_DIR)/locale.c $(GENERIC_DIR)/nfa.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/compile.c + +exec.o: $(GENERIC_DIR)/exec.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/exec.c tclAppInit.o: $(UNIX_DIR)/tclAppInit.c $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclAppInit.c @@ -590,12 +623,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 @@ -644,6 +683,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 @@ -689,6 +731,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 + tclPipe.o: $(GENERIC_DIR)/tclPipe.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclPipe.c @@ -704,12 +749,21 @@ 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 + +tclResult.o: $(GENERIC_DIR)/tclResult.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclResult.c + tclStringObj.o: $(GENERIC_DIR)/tclStringObj.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclStringObj.c tclUtil.o: $(GENERIC_DIR)/tclUtil.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclUtil.c +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 @@ -722,6 +776,12 @@ tclTestObj.o: $(GENERIC_DIR)/tclTestObj.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 @@ -746,10 +806,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 @@ -765,6 +828,9 @@ getcwd.o: $(COMPAT_DIR)/getcwd.c opendir.o: $(COMPAT_DIR)/opendir.c $(CC) -c $(CC_SWITCHES) $(COMPAT_DIR)/opendir.c +memcmp.o: $(COMPAT_DIR)/memcmp.c + $(CC) -c $(CC_SWITCHES) $(COMPAT_DIR)/memcmp.c + strncasecmp.o: $(COMPAT_DIR)/strncasecmp.c $(CC) -c $(CC_SWITCHES) $(COMPAT_DIR)/strncasecmp.c @@ -843,11 +909,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; \ 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 @@ -859,7 +927,7 @@ dist: $(UNIX_DIR)/configure cp -p $(TOP_DIR)/license.terms $(DISTDIR)/tests cp -p $(TOP_DIR)/tests/*.test $(TOP_DIR)/tests/README \ $(TOP_DIR)/tests/all $(TOP_DIR)/tests/remote.tcl \ - $(TOP_DIR)/tests/defs $(DISTDIR)/tests + $(TOP_DIR)/tests/defs $(TOP_DIR)/tests/httpd $(DISTDIR)/tests mkdir $(DISTDIR)/win cp -p $(TOP_DIR)/win/*.c $(TOP_DIR)/win/*.h $(TOP_DIR)/win/*.rc \ $(DISTDIR)/win @@ -884,6 +952,12 @@ 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 + @echo "ignore 'cp: xxx: is a directory' errors" + -@for i in tools tools/encoding ; do \ + echo "making $(DISTDIR)/$$i"; \ + mkdir -p $(DISTDIR)/$$i;\ + cp `ls -d1 $(TOP_DIR)/$$i/*|egrep -v "(SCCS|TAGS|~|,|#|%|core|\.l?o)"` $(DISTDIR)/$$i;\ + done # # The following target can only be used for non-patch releases. Use @@ -891,10 +965,10 @@ dist: $(UNIX_DIR)/configure # alldist: dist - rm -f /proj/tcl/dist/$(DISTNAME).tar.Z \ - /proj/tcl/dist/$(DISTNAME).tar.gz \ - /proj/tcl/dist/$(ZIPNAME) - cd /proj/tcl/dist; tar cf $(DISTNAME).tar $(DISTNAME); \ + rm -f $(DISTDIR)/../$(DISTNAME).tar.Z \ + $(DISTDIR)/../$(DISTNAME).tar.gz \ + $(DISTDIR)/../$(ZIPNAME) + cd $(DISTDIR)/..; tar cf $(DISTNAME).tar $(DISTNAME); \ gzip -9 -c $(DISTNAME).tar > $(DISTNAME).tar.gz; \ compress $(DISTNAME).tar; zip -r8 $(ZIPNAME) $(DISTNAME) @@ -919,18 +993,26 @@ allpatch: dist mv /proj/tcl/dist/old /proj/tcl/dist/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 # programs found only in the Tcl group's tool workspace. # -macdist: dist +macdist: dist html rm -f $(DISTDIR)/mac/tclMacProjects.sit.hqx - tclsh $(TOOL_DIR)/man2html.tcl $(DISTDIR)/tmp ../.. tcl$(VERSION) - mv $(DISTDIR)/tmp/tcl$(VERSION) $(DISTDIR)/html rm -rf $(DISTDIR)/doc - rm -rf $(DISTDIR)/tmp tclsh $(TOOL_DIR)/cvtEOL.tcl $(DISTDIR) # diff --git a/unix/README b/unix/README index 96c79c1..3725d49 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. -SCCS: @(#) README 1.15 96/12/19 14:02:23 +SCCS: @(#) README 1.17 98/02/18 15:07:42 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,15 @@ How To Compile And Install Tcl: Tcl then you'll first need to set your TCL_LIBRARY variable to hold the full path name of the "library" subdirectory. Note that the installed versions of tclsh, libtcl.a, and libtcl.so have a - version number in their names, such as "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. Or, check out the following Web URL: - http://www.sunlabs.com/cgi-bin/tcl/info.8.0 + http://www.sunlabs.com/cgi-bin/tcl/info.8.1 This is an on-line database of porting information. We make no guarantees that this information is accurate, complete, or up-to-date, but you may find it useful. If you get Tcl running on a new configuration, we would diff --git a/unix/configure.in b/unix/configure.in index ee36dc4..e1bf054 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) -# SCCS: @(#) configure.in 1.144 97/11/20 12:39:44 +# SCCS: @(#) configure.in 1.156 98/02/23 17:51:51 -TCL_VERSION=8.0 +TCL_VERSION=8.1 TCL_MAJOR_VERSION=8 -TCL_MINOR_VERSION=0 -TCL_PATCH_LEVEL="p2" +TCL_MINOR_VERSION=1 +TCL_PATCH_LEVEL=a2 VERSION=${TCL_VERSION} if test "${prefix}" = "NONE"; then @@ -29,6 +29,24 @@ 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_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 + #-------------------------------------------------------------------- # Supply substitutes for missing POSIX library procedures, or # set flags so Tcl uses alternate procedures. @@ -46,6 +64,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 @@ -120,6 +139,8 @@ 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 @@ -270,9 +291,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 @@ -567,6 +602,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: @@ -670,7 +709,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" diff --git a/unix/dltest/pkge.c b/unix/dltest/pkge.c index 1d585ca..f5b84a6 100644 --- a/unix/dltest/pkge.c +++ b/unix/dltest/pkge.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) pkge.c 1.5 96/03/07 09:34:27 + * SCCS: @(#) pkge.c 1.6 97/10/20 13:17:59 */ #include "tcl.h" @@ -45,5 +45,6 @@ Pkge_Init(interp) Tcl_Interp *interp; /* Interpreter in which the package is * to be made available. */ { - return Tcl_Eval(interp, "if 44 {open non_existent}"); + static char script[] = "if 44 {open non_existent}"; + return Tcl_Eval(interp, script); } diff --git a/unix/mkLinks b/unix/mkLinks index b4da360..494a9ea 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 @@ -299,6 +319,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 @@ -311,6 +335,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 @@ -336,12 +364,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 @@ -387,10 +427,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 @@ -411,6 +463,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 @@ -431,6 +491,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 @@ -479,6 +543,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 @@ -523,6 +599,10 @@ if test -r ObjectType.3; then rm -f Tcl_GetObjType.3 ln ObjectType.3 Tcl_GetObjType.3 fi +if test -r SetVar.3; then + rm -f Tcl_GetObjVar2.3 + ln SetVar.3 Tcl_GetObjVar2.3 +fi if test -r GetOpnFl.3; then rm -f Tcl_GetOpenFile.3 ln GetOpnFl.3 Tcl_GetOpenFile.3 @@ -544,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 @@ -551,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,14 +651,14 @@ 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 @@ -659,10 +747,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 @@ -695,13 +795,9 @@ if test -r CrtChannel.3; then rm -f Tcl_NotifyChannel.3 ln CrtChannel.3 Tcl_NotifyChannel.3 fi -if test -r ObjSetVar.3; then - rm -f Tcl_ObjGetVar2.3 - ln ObjSetVar.3 Tcl_ObjGetVar2.3 -fi -if test -r ObjSetVar.3; then - rm -f Tcl_ObjSetVar2.3 - ln ObjSetVar.3 Tcl_ObjSetVar2.3 +if test -r Utf.3; then + rm -f Tcl_NumUtfChars.3 + ln Utf.3 Tcl_NumUtfChars.3 fi if test -r OpenFileChnl.3; then rm -f Tcl_OpenCommandChannel.3 @@ -719,6 +815,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 @@ -747,6 +863,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 @@ -795,6 +915,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 @@ -819,6 +947,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 @@ -875,6 +1011,10 @@ if test -r SetResult.3; then rm -f Tcl_SetObjResult.3 ln SetResult.3 Tcl_SetObjResult.3 fi +if test -r SetVar.3; then + rm -f Tcl_SetObjVar2.3 + ln SetVar.3 Tcl_SetObjVar2.3 +fi if test -r SetRecLmt.3; then rm -f Tcl_SetRecursionLimit.3 ln SetRecLmt.3 Tcl_SetRecursionLimit.3 @@ -895,6 +1035,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 @@ -943,6 +1087,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 @@ -979,6 +1147,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 @@ -999,6 +1219,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/tclAppInit.c b/unix/tclAppInit.c index fafa31e..888769b 100644 --- a/unix/tclAppInit.c +++ b/unix/tclAppInit.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tclAppInit.c 1.20 97/03/24 14:29:43 + * SCCS: @(#) tclAppInit.c 1.30 98/02/18 16:57:43 */ #ifdef TCL_XT_TEST @@ -29,9 +29,17 @@ int *tclDummyMathPtr = (int *) matherr; #ifdef TCL_TEST + +#include "tclInt.h" + 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 @@ -58,9 +66,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. */ } @@ -76,7 +95,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. @@ -106,6 +125,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 #endif /* TCL_TEST */ /* diff --git a/unix/tclLoadAix.c b/unix/tclLoadAix.c index edf33d6..ac701b2 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. * - * SCCS: @(#) tclLoadAix.c 1.11 96/10/07 10:41:24 + * SCCS: @(#) tclLoadAix.c 1.12 97/08/27 19:19:54 * * 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 ade7161..0ab75f9 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. * - * SCCS: @(#) tclLoadAout.c 1.9 97/02/22 14:05:01 + * SCCS: @(#) tclLoadAout.c 1.14 98/01/12 15:28:58 */ #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 2619bfd..6b70269 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. * - * SCCS: @(#) tclLoadDl.c 1.8 96/12/03 16:57:00 + * SCCS: @(#) tclLoadDl.c 1.11 97/12/11 10:59:33 */ #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 0ef994a..7a11bae 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. * - * SCCS: @(#) tclLoadDld.c 1.5 97/05/14 13:24:22 + * SCCS: @(#) tclLoadDld.c 1.7 97/12/11 10:59:40 */ #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 ed4b823..e96cebc 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. * - * SCCS: @(#) tclLoadNext.c 1.4 96/02/15 11:58:55 + * SCCS: @(#) tclLoadNext.c 1.6 97/12/11 11:00:48 */ #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 ca8c8fc..0615870 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. * - * SCCS: @(#) tclLoadOSF.c 1.2 96/02/15 11:58:40 + * SCCS: @(#) tclLoadOSF.c 1.4 97/12/11 10:59:16 */ #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 2f290ab..a228d39 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. * - * SCCS: @(#) tclLoadShl.c 1.5 96/03/15 15:01:44 + * SCCS: @(#) tclLoadShl.c 1.9 98/01/07 16:23:57 */ #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 24b815d..dd86154 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. * - * SCCS: @(#) tclMtherr.c 1.12 96/06/22 16:36:57 + * SCCS: @(#) tclMtherr.c 1.14 98/02/13 15:35:28 */ #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 2c0e996..5217fe2 100644 --- a/unix/tclUnixChan.c +++ b/unix/tclUnixChan.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tclUnixChan.c 1.207 97/11/04 14:45:29 + * SCCS: @(#) tclUnixChan.c 1.217 98/02/18 18:23:24 */ #include "tclInt.h" /* Internal definitions for Tcl. */ @@ -40,31 +40,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 +79,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. + */ + +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 FileState *firstFilePtr = NULL; +static Tcl_ThreadDataKey dataKey; /* * This structure describes per-instance state of a tcp based channel. @@ -170,20 +204,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 +242,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 +251,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 +260,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 +443,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; @@ -536,6 +582,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 +622,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 +691,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 +897,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 +917,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; + + GETIOSTATE(fd, &iostate); - tcgetattr(fd, &termios); - ttyPtr->baud = TtyGetBaud(cfgetospeed(&termios)); +#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 +1007,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 +1036,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 +1065,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 +1101,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 +1156,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 */ + +/* *---------------------------------------------------------------------- * * Tcl_OpenFileChannel -- @@ -1157,7 +1226,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 +1248,11 @@ Tcl_OpenFileChannel(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 +1276,13 @@ Tcl_OpenFileChannel(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 +1302,7 @@ Tcl_OpenFileChannel(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 +1312,22 @@ Tcl_OpenFileChannel(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 +1342,7 @@ Tcl_OpenFileChannel(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 +1352,7 @@ Tcl_OpenFileChannel(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 +1384,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 +1399,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 +1679,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,7 +1728,7 @@ 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); @@ -1662,21 +1737,25 @@ TcpGetOptionProc(instanceData, interp, optionName, dsPtr) 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); @@ -1712,14 +1791,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); @@ -1818,8 +1901,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. @@ -1958,7 +2041,7 @@ bindError: statePtr->flags = TCP_ASYNC_CONNECT; } statePtr->fd = sock; - + return statePtr; addressError: @@ -2004,9 +2087,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], @@ -2019,9 +2110,15 @@ CreateSocketAddress(sockaddrPtr, host, port) errno = ENXIO; #endif #endif + if (native != NULL) { + Tcl_DStringFree(&ds); + } return 0; /* error */ } } + if (native != NULL) { + Tcl_DStringFree(&ds); + } } /* @@ -2064,7 +2161,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. @@ -2111,7 +2208,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; @@ -2139,7 +2236,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: @@ -2159,7 +2256,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. @@ -2213,12 +2310,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; } @@ -2234,18 +2331,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)); } @@ -2254,7 +2351,7 @@ TcpAccept(data, mask) /* *---------------------------------------------------------------------- * - * TclGetDefaultStdChannel -- + * TclpGetDefaultStdChannel -- * * Creates channels for standard input, standard output or standard * error output if they do not already exist. @@ -2270,7 +2367,7 @@ TcpAccept(data, mask) */ Tcl_Channel -TclGetDefaultStdChannel(type) +TclpGetDefaultStdChannel(type) int type; /* One of TCL_STDIN, TCL_STDOUT, TCL_STDERR. */ { Tcl_Channel channel = NULL; @@ -2336,7 +2433,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. @@ -2385,7 +2482,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), @@ -2453,7 +2554,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 24841ca..26eff5f 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. * - * SCCS: @(#) tclUnixEvent.c 1.1 97/03/04 14:19:34 + * SCCS: @(#) tclUnixEvent.c 1.2 98/02/04 16:21:02 */ #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 3ec1a69..83f4bfb 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. * - * SCCS: @(#) tclUnixFCmd.c 1.31 97/10/13 16:51:14 + * SCCS: @(#) tclUnixFCmd.c 1.36 98/02/18 18:24:52 * * 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,43 @@ 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 +#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 +228,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 +250,7 @@ TclpRenameFile(src, dst) } errno = EINVAL; } -#endif /* sparc */ +#endif /* !NO_REALPATH */ if (strcmp(src, "/") == 0) { /* @@ -230,7 +275,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 +301,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 +343,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 +409,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 +422,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 +465,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 +484,7 @@ CopyFile(src, dst, srcStatBufPtr) /* *--------------------------------------------------------------------------- * - * TclpDeleteFile -- + * TclpDeleteFile, DoDeleteFile -- * * Removes a single file (not a directory). * @@ -424,9 +505,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 +532,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 +557,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 +583,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 +620,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 +668,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); + + 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; - if (rmdir(path) == 0) { + path = Tcl_DStringValue(pathPtr); + if (rmdir(path) == 0) { /* INTL: Native. */ return TCL_OK; } if (errno == ENOTEMPTY) { @@ -573,7 +709,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 +719,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 +749,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 +789,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 +814,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 +833,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 +850,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 +883,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 +916,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 +947,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 +1022,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 +1032,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 +1060,32 @@ 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; + Tcl_DString ds; + CONST char *native, *utf; + int result; - if (stat(fileName, &statBuf) != 0) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "could not stat file \"", fileName, "\": ", + native = Tcl_UtfToExternalDString(NULL, fileName, -1, &ds); + result = stat(native, &statBuf); /* INTL: Native. */ + Tcl_DStringFree(&ds); + + 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); + utf = Tcl_ExternalToUtfDString(NULL, groupPtr->gr_name, -1, &ds); + *attributePtrPtr = Tcl_NewStringObj(utf, -1); + Tcl_DStringFree(&ds); } endgrent(); return TCL_OK; @@ -971,24 +1112,32 @@ 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; + Tcl_DString ds; + CONST char *native, *utf; + int result; - if (stat(fileName, &statBuf) != 0) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "could not stat file \"", fileName, "\": ", + native = Tcl_UtfToExternalDString(NULL, fileName, -1, &ds); + result = stat(native, &statBuf); /* INTL: Native. */ + Tcl_DStringFree(&ds); + + 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); + 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 +1164,21 @@ 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]; + Tcl_DString ds; + CONST char *native; + int result; - if (stat(fileName, &statBuf) != 0) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "could not stat file \"", fileName, "\": ", + native = Tcl_UtfToExternalDString(NULL, fileName, -1, &ds); + result = stat(native, &statBuf); /* INTL: Native. */ + Tcl_DStringFree(&ds); + + if (result != 0) { + Tcl_AppendResult(interp, "could not read \"", fileName, "\": ", Tcl_PosixError(interp), (char *) NULL); return TCL_ERROR; } @@ -1036,155 +1191,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 eb11006..e826fdb 100644 --- a/unix/tclUnixFile.c +++ b/unix/tclUnixFile.c @@ -4,204 +4,20 @@ * 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. * - * SCCS: @(#) tclUnixFile.c 1.48 97/07/07 16:38:11 + * SCCS: @(#) tclUnixFile.c 1.58 98/01/17 00:01:01 */ #include "tclInt.h" #include "tclPort.h" -/* - * The variable below caches the name of the current working directory - * in order to avoid repeated calls to getcwd. The string is malloc-ed. - * NULL means the cache needs to be refreshed. - */ - -static char *currentDir = NULL; -static int currentDirExitHandlerSet = 0; - -/* - * The variable below is set if the exit routine for deleting the string - * containing the executable name has been registered. - */ - -static int executableNameExitHandlerSet = 0; - -extern pid_t waitpid _ANSI_ARGS_((pid_t pid, int *stat_loc, int options)); - -/* - * Static routines for this file: - */ - -static void FreeCurrentDir _ANSI_ARGS_((ClientData clientData)); -static void FreeExecutableName _ANSI_ARGS_((ClientData clientData)); - -/* - *---------------------------------------------------------------------- - * - * FreeCurrentDir -- - * - * Frees the string stored in the currentDir variable. This routine - * is registered as an exit handler and will be called during shutdown. - * - * Results: - * None. - * - * Side effects: - * Frees the memory occuppied by the currentDir value. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -static void -FreeCurrentDir(clientData) - ClientData clientData; /* Not used. */ -{ - if (currentDir != (char *) NULL) { - ckfree(currentDir); - currentDir = (char *) NULL; - currentDirExitHandlerSet = 0; - } -} - -/* - *---------------------------------------------------------------------- - * - * FreeExecutableName -- - * - * Frees the string stored in the tclExecutableName variable. This - * routine is registered as an exit handler and will be called - * during shutdown. - * - * Results: - * None. - * - * Side effects: - * Frees the memory occuppied by the tclExecutableName value. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -static void -FreeExecutableName(clientData) - ClientData clientData; /* Not used. */ -{ - if (tclExecutableName != (char *) NULL) { - ckfree(tclExecutableName); - tclExecutableName = (char *) NULL; - } -} - -/* - *---------------------------------------------------------------------- - * - * TclChdir -- - * - * Change the current working directory. - * - * Results: - * The result is a standard Tcl result. If an error occurs and - * interp isn't NULL, an error message is left in interp->result. - * - * Side effects: - * The working directory for this application is changed. Also - * the cache maintained used by TclGetCwd is deallocated and - * set to NULL. - * - *---------------------------------------------------------------------- - */ - -int -TclChdir(interp, dirName) - Tcl_Interp *interp; /* If non NULL, used for error reporting. */ - char *dirName; /* Path to new working directory. */ -{ - if (currentDir != NULL) { - ckfree(currentDir); - currentDir = NULL; - } - if (chdir(dirName) != 0) { - if (interp != NULL) { - Tcl_AppendResult(interp, "couldn't change working directory to \"", - dirName, "\": ", Tcl_PosixError(interp), (char *) NULL); - } - return TCL_ERROR; - } - return TCL_OK; -} /* - *---------------------------------------------------------------------- - * - * TclGetCwd -- - * - * Return the path name of the current working directory. - * - * Results: - * The result is the full path name of the current working - * directory, or NULL if an error occurred while figuring it out. - * The returned string is owned by the TclGetCwd routine and must - * not be freed by the caller. If an error occurs and interp - * isn't NULL, an error message is left in interp->result. - * - * Side effects: - * The path name is cached to avoid having to recompute it - * on future calls; if it is already cached, the cached - * value is returned. - * - *---------------------------------------------------------------------- - */ - -char * -TclGetCwd(interp) - Tcl_Interp *interp; /* If non NULL, used for error reporting. */ -{ - char buffer[MAXPATHLEN+1]; - - if (currentDir == NULL) { - if (!currentDirExitHandlerSet) { - currentDirExitHandlerSet = 1; - Tcl_CreateExitHandler(FreeCurrentDir, (ClientData) NULL); - } -#ifdef USEGETWD - if ((int)getwd(buffer) == (int)NULL) { - if (interp != NULL) { - Tcl_AppendResult(interp, - "error getting working directory name: ", - buffer, (char *)NULL); - } - return NULL; - } -#else - if (getcwd(buffer, MAXPATHLEN+1) == NULL) { - if (interp != NULL) { - if (errno == ERANGE) { - Tcl_SetResult(interp, - "working directory name is too long", - TCL_STATIC); - } else { - Tcl_AppendResult(interp, - "error getting working directory name: ", - Tcl_PosixError(interp), (char *) NULL); - } - } - return NULL; - } -#endif - currentDir = (char *) ckalloc((unsigned) (strlen(buffer) + 1)); - strcpy(currentDir, buffer); - } - return currentDir; -} - -/* - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- * * Tcl_FindExecutable -- * @@ -214,28 +30,35 @@ TclGetCwd(interp) * Side effects: * The variable tclExecutableName gets filled in with the file * name for the application, if we figured it out. If we couldn't - * figure it out, Tcl_FindExecutable is set to NULL. + * figure it out, tclExecutableName is set to NULL. * - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- */ void Tcl_FindExecutable(argv0) - char *argv0; /* The value of the application's argv[0]. */ + CONST char *argv0; /* The value of the application's argv[0] + * (native). */ { - char *name, *p, *cwd; - Tcl_DString buffer; + CONST char *name, *p; int length; struct stat statBuf; + Tcl_DString buffer, nameString; - Tcl_DStringInit(&buffer); + TclInitSubsystems(argv0); + + if (argv0 == NULL) { + return; + } if (tclExecutableName != NULL) { ckfree(tclExecutableName); tclExecutableName = NULL; } + 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 @@ -246,7 +69,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 @@ -262,8 +85,8 @@ Tcl_FindExecutable(argv0) * name. */ - while (*p != 0) { - while (isspace(UCHAR(*p))) { + while (1) { + while (isspace(UCHAR(*p))) { /* INTL: BUG */ p++; } name = p; @@ -272,19 +95,18 @@ 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 ((access(Tcl_DStringValue(&buffer), X_OK) == 0) - && (stat(Tcl_DStringValue(&buffer), &statBuf) == 0) + name = Tcl_DStringAppend(&buffer, argv0, -1); + 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; } p++; @@ -297,8 +119,11 @@ Tcl_FindExecutable(argv0) gotName: if (name[0] == '/') { - tclExecutableName = (char *) ckalloc((unsigned) (strlen(name) + 1)); - strcpy(tclExecutableName, name); + Tcl_ExternalToUtfDString(NULL, name, -1, &nameString); + tclExecutableName = (char *) + ckalloc((unsigned) (Tcl_DStringLength(&nameString) + 1)); + strcpy(tclExecutableName, Tcl_DStringValue(&nameString)); + Tcl_DStringFree(&nameString); goto done; } @@ -311,79 +136,34 @@ 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); - done: Tcl_DStringFree(&buffer); + TclpGetCwd(NULL, &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; + length = Tcl_DStringLength(&buffer) + Tcl_DStringLength(&nameString) + 2; + tclExecutableName = (char *) ckalloc((unsigned) length); + strcpy(tclExecutableName, Tcl_DStringValue(&buffer)); + tclExecutableName[Tcl_DStringLength(&buffer)] = '/'; + strcpy(tclExecutableName + Tcl_DStringLength(&buffer) + 1, + Tcl_DStringValue(&nameString)); + Tcl_DStringFree(&nameString); - pwPtr = getpwnam(name); - if (pwPtr == NULL) { - endpwent(); - return NULL; - } - Tcl_DStringInit(bufferPtr); - Tcl_DStringAppend(bufferPtr, pwPtr->pw_dir, -1); - endpwent(); - return bufferPtr->string; + done: + Tcl_DStringFree(&buffer); } /* *---------------------------------------------------------------------- * - * 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. @@ -395,19 +175,18 @@ 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 *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); @@ -420,12 +199,16 @@ 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; } - if ((stat(dirName, &statBuf) != 0) || !S_ISDIR(statBuf.st_mode)) { + + native = Tcl_UtfToExternalDString(NULL, dirName, -1, &ds); + if ((stat(native, &statBuf) != 0) /* INTL: Native. */ + || !S_ISDIR(statBuf.st_mode)) { + Tcl_DStringFree(&ds); return TCL_OK; } @@ -444,7 +227,8 @@ TclMatchFiles(interp, separators, dirPtr, pattern, tail) * Now open the directory for reading and iterate over the contents. */ - d = opendir(dirName); + d = opendir(native); /* INTL: Native. */ + Tcl_DStringFree(&ds); if (d == NULL) { Tcl_ResetResult(interp); @@ -485,7 +269,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; } @@ -506,23 +293,285 @@ 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 ((stat(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; closedir(d); return result; } + +/* + *--------------------------------------------------------------------------- + * + * TclpGetUserHome -- + * + * This function takes the specified user name and finds their + * home directory. + * + * Results: + * The result is a pointer to a string specifying the user's home + * directory, or NULL if the user's home directory could not be + * determined. Storage for the result string is allocated in + * bufferPtr; the caller must call Tcl_DStringFree() when the result + * is no longer needed. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +char * +TclpGetUserHome(name, bufferPtr) + CONST char *name; /* User name for desired home directory. */ + Tcl_DString *bufferPtr; /* Uninitialized or free DString filled + * with name of user's home directory. */ +{ + struct passwd *pwPtr; + Tcl_DString ds; + char *native; + + native = Tcl_UtfToExternalDString(NULL, name, -1, &ds); + pwPtr = getpwnam(native); /* INTL: Native. */ + Tcl_DStringFree(&ds); + + if (pwPtr == NULL) { + endpwent(); + return NULL; + } + Tcl_ExternalToUtfDString(NULL, pwPtr->pw_dir, -1, bufferPtr); + endpwent(); + return Tcl_DStringValue(bufferPtr); +} + +/* + *--------------------------------------------------------------------------- + * + * TclpAccess -- + * + * This function replaces the library version of access(). + * + * Results: + * See access() documentation. + * + * Side effects: + * See access() documentation. + * + *--------------------------------------------------------------------------- + */ + +int +TclpAccess(path, mode) + CONST char *path; /* Path of file to access (UTF-8). */ + int mode; /* Permission setting. */ +{ + int result; + Tcl_DString ds; + char *native; + + native = Tcl_UtfToExternalDString(NULL, path, -1, &ds); + result = access(native, mode); /* INTL: Native. */ + Tcl_DStringFree(&ds); + + return result; +} + +/* + *--------------------------------------------------------------------------- + * + * TclpChdir -- + * + * This function replaces the library version of chdir(). + * + * Results: + * See chdir() documentation. + * + * Side effects: + * See chdir() documentation. + * + *--------------------------------------------------------------------------- + */ + +int +TclpChdir(dirName) + CONST char *dirName; /* Path to new working directory (UTF-8). */ +{ + int result; + Tcl_DString ds; + char *native; + + native = Tcl_UtfToExternalDString(NULL, dirName, -1, &ds); + result = chdir(native); /* INTL: Native. */ + Tcl_DStringFree(&ds); + + return result; +} + +/* + *---------------------------------------------------------------------- + * + * TclpLstat -- + * + * This function replaces the library version of lstat(). + * + * Results: + * See lstat() documentation. + * + * Side effects: + * See lstat() documentation. + * + *---------------------------------------------------------------------- + */ + +int +TclpLstat(path, bufPtr) + CONST char *path; /* Path of file to stat (UTF-8). */ + struct stat *bufPtr; /* Filled with results of stat call. */ +{ + int result; + Tcl_DString ds; + char *native; + + native = Tcl_UtfToExternalDString(NULL, path, -1, &ds); + result = lstat(native, bufPtr); /* INTL: Native. */ + Tcl_DStringFree(&ds); + + return result; +} + +/* + *--------------------------------------------------------------------------- + * + * TclpGetCwd -- + * + * This function replaces the library version of getcwd(). + * + * Results: + * The result is a pointer to a string specifying the current + * directory, or NULL if the current directory could not be + * determined. If NULL is returned, an error message is left in the + * interp's result. Storage for the result string is allocated in + * bufferPtr; the caller must call Tcl_DStringFree() when the result + * is no longer needed. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +char * +TclpGetCwd(interp, bufferPtr) + Tcl_Interp *interp; /* If non-NULL, used for error reporting. */ + Tcl_DString *bufferPtr; /* Uninitialized or free DString filled + * with name of current directory. */ +{ + char buffer[MAXPATHLEN+1]; + +#ifdef USEGETWD + if (getwd(buffer) == NULL) { /* INTL: Native. */ +#else + if (getcwd(buffer, MAXPATHLEN + 1) == NULL) { /* INTL: Native. */ +#endif + if (interp != NULL) { + Tcl_AppendResult(interp, + "error getting working directory name: ", + Tcl_PosixError(interp), (char *) NULL); + } + return NULL; + } + return Tcl_ExternalToUtfDString(NULL, buffer, -1, bufferPtr); +} + +/* + *--------------------------------------------------------------------------- + * + * TclpReadlink -- + * + * This function replaces the library version of readlink(). + * + * Results: + * The result is a pointer to a string specifying the contents + * of the symbolic link given by 'path', or NULL if the symbolic + * link could not be read. Storage for the result string is + * allocated in bufferPtr; the caller must call Tcl_DStringFree() + * when the result is no longer needed. + * + * Side effects: + * See readlink() documentation. + * + *--------------------------------------------------------------------------- + */ + +char * +TclpReadlink(path, linkPtr) + CONST char *path; /* Path of file to readlink (UTF-8). */ + Tcl_DString *linkPtr; /* Uninitialized or free DString filled + * with contents of link (UTF-8). */ +{ + char link[MAXPATHLEN]; + int length; + char *native; + Tcl_DString ds; + + native = Tcl_UtfToExternalDString(NULL, path, -1, &ds); + length = readlink(native, link, sizeof(link)); /* INTL: Native. */ + Tcl_DStringFree(&ds); + + if (length < 0) { + return NULL; + } + + Tcl_ExternalToUtfDString(NULL, link, length, linkPtr); + return Tcl_DStringValue(linkPtr); +} + +/* + *---------------------------------------------------------------------- + * + * TclpStat -- + * + * This function replaces the library version of stat(). + * + * Results: + * See stat() documentation. + * + * Side effects: + * See stat() documentation. + * + *---------------------------------------------------------------------- + */ + +int +TclpStat(path, bufPtr) + CONST char *path; /* Path of file to stat (in UTF-8). */ + struct stat *bufPtr; /* Filled with results of stat call. */ +{ + int result; + Tcl_DString ds; + char *native; + + native = Tcl_UtfToExternalDString(NULL, path, -1, &ds); + result = stat(native, bufPtr); /* INTL: Native. */ + Tcl_DStringFree(&ds); + + return result; +} + diff --git a/unix/tclUnixInit.c b/unix/tclUnixInit.c index 91d866f..f7d00a1 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. * - * SCCS: @(#) tclUnixInit.c 1.26 97/08/05 20:09:25 + * SCCS: @(#) tclUnixInit.c 1.39 98/01/20 23:00:59 */ #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,99 +46,372 @@ static char defaultLibraryDir[200] = TCL_LIBRARY; static char pkgPath[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"}, -static int initialized = 0; + {"zh", "cp936"}, + {NULL, NULL} +}; + /* - * The following string is the startup script executed in new - * interpreters. It looks on disk in several different directories - * for a script "init.tcl" that is compatible with this version - * of Tcl. The init.tcl script does all of the real work of - * initialization. + *--------------------------------------------------------------------------- + * + * TclpInitPlatform -- + * + * Initialize all the platform-dependant things like signals and + * floating-point error handling. + * + * Called at process initialization time. + * + * Results: + * None. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- */ -static char initScript[] = -"proc tclInit {} {\n\ - global tcl_library tcl_version tcl_patchLevel env errorInfo\n\ - global tcl_pkgPath\n\ - rename tclInit {}\n\ - set errors {}\n\ - set dirs {}\n\ - if [info exists env(TCL_LIBRARY)] {\n\ - lappend dirs $env(TCL_LIBRARY)\n\ - }\n\ - lappend dirs [info library]\n\ - set parentDir [file dirname [file dirname [info nameofexecutable]]]\n\ - lappend dirs $parentDir/lib/tcl$tcl_version\n\ - if [string match {*[ab]*} $tcl_patchLevel] {\n\ - set lib tcl$tcl_patchLevel\n\ - } else {\n\ - set lib tcl$tcl_version\n\ - }\n\ - lappend dirs [file dirname $parentDir]/$lib/library\n\ - lappend dirs $parentDir/library\n\ - foreach i $dirs {\n\ - set tcl_library $i\n\ - set tclfile [file join $i init.tcl]\n\ - if {[file exists $tclfile]} {\n\ - lappend tcl_pkgPath [file dirname $i]\n\ - if ![catch {uplevel #0 [list source $tclfile]} msg] {\n\ - return\n\ - } else {\n\ - append errors \"$tclfile: $msg\n$errorInfo\n\"\n\ - }\n\ - }\n\ - }\n\ - set msg \"Can't find a usable init.tcl in the following directories: \n\"\n\ - append msg \" $dirs\n\n\"\n\ - append msg \"$errors\n\n\"\n\ - append msg \"This probably means that Tcl wasn't installed properly.\n\"\n\ - error $msg\n\ -}\n\ -tclInit"; +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(argv0) +CONST char *argv0; /* Name of executable from argv[0] to + * main(). */ +{ +#define LIBRARY_SIZE 32 + Tcl_Obj *pathPtr, *objPtr; + char *str; + Tcl_DString ds; + int pathc; + char **pathv; + char installLib[LIBRARY_SIZE], developLib[LIBRARY_SIZE]; + + Tcl_DStringInit(&ds); + pathPtr = Tcl_NewObj(); + + /* + * set installLib lib/tcl[info tclversion] + * + * if {[string match {*[ab]*} [info patchlevel]} { + * set developLib tcl[info patchlevel]/library + * } else { + * set developLib tcl[info tclversion]/library + * } + */ + + sprintf(installLib, "lib/tcl%s", TCL_VERSION); + sprintf(developLib, "tcl%s/library", + ((TCL_RELEASE_LEVEL < 2) ? TCL_PATCH_LEVEL : TCL_VERSION)); + + /* + * if {[info exists $env(TCL_LIBRARY)]} { + * lappend dirs $env(TCL_LIBRARY) + * set split [file split $TCL_LIBRARY] + * set tail [lindex [file split $installLib] end] + * if {[string tolower [lindex $split end]] != $tail} { + * set split [lreplace $split end end $tail] + * lappend dirs [eval file join $split] + * } + * } + */ + + str = getenv("TCL_LIBRARY"); /* INTL: Native. */ + 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); + } + + /* + * if {[info exists $auto_path]} { + * eval lappend dirs $auto_path + * } + */ + + objPtr = TclGetLibraryPath(); + if (objPtr != NULL) { + Tcl_ListObjAppendList(NULL, pathPtr, objPtr); + } + + /* + * if {[info nameofexecutable] != ""} { + * set dir [file dirname [file dirname [info nameofexecutable]]] + * lappend dirs [file join $dir $installLib] + * lappend dirs [file join [file dirname $dir] $developLib] + * } + */ + + Tcl_FindExecutable(argv0); + str = tclExecutableName; + if (str != NULL) { + Tcl_SplitPath(str, &pathc, &pathv); + if (pathc > 1) { + pathv[pathc - 2] = installLib; + str = Tcl_JoinPath(pathc - 1, pathv, &ds); + objPtr = Tcl_NewStringObj(str, Tcl_DStringLength(&ds)); + Tcl_ListObjAppendElement(NULL, pathPtr, objPtr); + Tcl_DStringFree(&ds); + } + if (pathc > 2) { + pathv[pathc - 3] = developLib; + str = Tcl_JoinPath(pathc - 2, pathv, &ds); + objPtr = Tcl_NewStringObj(str, Tcl_DStringLength(&ds)); + Tcl_ListObjAppendElement(NULL, pathPtr, objPtr); + Tcl_DStringFree(&ds); + } + ckfree((char *) pathv); + } + + /* + * if {$tcl_library != ""} { + * lappend dirs $tcl_library + * } + */ + + str = defaultLibraryDir; + if (str[0] != '\0') { + objPtr = Tcl_NewStringObj(str, -1); + Tcl_ListObjAppendElement(NULL, pathPtr, objPtr); + } + TclSetLibraryPath(pathPtr); +} /* - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- * - * 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() { - strcpy(defaultLibraryDir, TCL_LIBRARY); - strcpy(pkgPath, TCL_PACKAGE_PATH); - initialized = 0; + CONST char *locale, *encoding; + int i; + Tcl_Obj *pathPtr; + Tcl_DString ds; + + /* + * Retrieve the old locale setting so we can restore it when we are done. + */ + + Tcl_DStringInit(&ds); + Tcl_DStringAppend(&ds, setlocale(LC_ALL, NULL), -1); + + setlocale(LC_ALL, ""); + locale = setlocale(LC_CTYPE, NULL); + if (locale == NULL) { + locale = "C"; + } + + /* + * Default encoding if locale cannot be identified. + */ + + encoding = "iso8859-1"; + + for (i = 0; localeTable[i].lang != NULL; i++) { + if (strcmp(localeTable[i].lang, locale) == 0) { + encoding = localeTable[i].encoding; + } + } + + /* + * Restore the locale settings. + */ + + setlocale(LC_ALL, Tcl_DStringValue(&ds)); + Tcl_DStringFree(&ds); + + 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: @@ -143,7 +424,7 @@ PlatformInitExitHandler(clientData) */ void -TclPlatformInit(interp) +TclpSetVariables(interp) Tcl_Interp *interp; { #ifndef NO_UNAME @@ -151,16 +432,21 @@ TclPlatformInit(interp) #endif int unameOK; - tclPlatform = TCL_PLATFORM_UNIX; Tcl_SetVar(interp, "tcl_library", defaultLibraryDir, TCL_GLOBAL_ONLY); Tcl_SetVar(interp, "tcl_pkgPath", pkgPath, TCL_GLOBAL_ONLY); Tcl_SetVar2(interp, "tcl_platform", "platform", "unix", TCL_GLOBAL_ONLY); unameOK = 0; #ifndef NO_UNAME if (uname(&name) >= 0) { + Tcl_DString ds; + 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 @@ -169,7 +455,8 @@ TclPlatformInit(interp) * name.version and the minor version number is in name.release. */ - if ((strchr(name.release, '.') != NULL) || !isdigit(name.version[0])) { + if ((strchr(name.release, '.') != NULL) + || !isdigit(name.version[0])) { /* INTL: digit */ Tcl_SetVar2(interp, "tcl_platform", "osVersion", name.release, TCL_GLOBAL_ONLY); } else { @@ -189,43 +476,6 @@ TclPlatformInit(interp) Tcl_SetVar2(interp, "tcl_platform", "osVersion", "", TCL_GLOBAL_ONLY); Tcl_SetVar2(interp, "tcl_platform", "machine", "", TCL_GLOBAL_ONLY); } - - if (!initialized) { - - /* - * Create an exit handler so that uninitialization will be done - * on unload. - */ - - Tcl_CreateExitHandler(PlatformInitExitHandler, NULL); - - /* - * The code below causes SIGPIPE (broken pipe) errors to - * be ignored. This is needed so that Tcl processes don't - * die if they create child processes (e.g. using "exec" or - * "open") that terminate prematurely. The signal handler - * is only set up when the first interpreter is created; - * after this the application can override the handler with - * a different one of its own, if it wants. - */ - -#ifdef SIGPIPE - (void) signal(SIGPIPE, SIG_IGN); -#endif /* SIGPIPE */ - -#ifdef __FreeBSD__ - fpsetround(FP_RN); - fpsetmask(0L); -#endif - -#if defined(__bsdi__) && (_BSDI_VERSION > 199501) - /* - * Find local symbols. Don't report an error if we fail. - */ - (void) dlopen (NULL, RTLD_NOW); -#endif - initialized = 1; - } } /* @@ -234,12 +484,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. @@ -251,6 +501,13 @@ int Tcl_Init(interp) Tcl_Interp *interp; /* Interpreter to initialize. */ { + Tcl_Obj *pathPtr; + + pathPtr = TclGetLibraryPath(); + if (pathPtr == NULL) { + pathPtr = Tcl_NewObj(); + } + Tcl_SetObjVar2(interp, "tcl_libPath", NULL, pathPtr, TCL_GLOBAL_ONLY); return Tcl_Eval(interp, initScript); } @@ -306,8 +563,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 1a86680..4f4683e 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. * - * SCCS: @(#) tclUnixNotfy.c 1.44 97/11/05 13:02:20 + * SCCS: @(#) tclUnixNotfy.c 1.55 98/02/23 17:19:20 */ #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,233 @@ 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; /* The notifier thread alerts a notifier + * that an event is ready to be processed + * by signaling this condition variable. */ +#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 static indicates whether this module has been initialized. + * 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 int initialized = 0; +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. + */ + +static Tcl_Mutex notifierMutex; + +/* + * The notifier thread signals the notifierCV when it has finished + * initializing the triggerPipe and right before the notifier + * thread terminates. + */ + +static Tcl_Condition notifierCV; + +/* + * The pollState bits + * POLL_WANT is set by each thread before it waits on its condition + * variable. It is checked by the notifier before it does + * select. + * POLL_DONE is set by the notifier if it goes into select after + * seeing POLL_WANT. The idea is to ensure it tries a select + * with the same bits the initial thread had set. + */ +#define POLL_WANT 0x1 +#define POLL_DONE 0x2 + +/* + * This is the thread ID of the notifier thread that does select. + */ +static Tcl_ThreadId notifierThread; + +#endif /* * Static routines defined in this file. */ -static void InitNotifier _ANSI_ARGS_((void)); -static void NotifierExitHandler _ANSI_ARGS_(( - ClientData clientData)); -static int FileHandlerEventProc _ANSI_ARGS_((Tcl_Event *evPtr, - int flags)); +static void NotifierThreadProc _ANSI_ARGS_((ClientData clientData)); +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 + /* + * 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) { + TclpConditionWait(¬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); + TclpConditionWait(¬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); + TclpConditionNotify(&tsdPtr->waitCV); + Tcl_MutexUnlock(¬ifierMutex); +#endif } /* @@ -194,25 +358,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; + 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 +386,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,17 +429,13 @@ 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; ; + for (prevPtr = NULL, filePtr = tsdPtr->firstFileHandlerPtr; ; prevPtr = filePtr, filePtr = filePtr->nextPtr) { if (filePtr == NULL) { return; @@ -296,31 +453,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 +488,7 @@ Tcl_DeleteFileHandler(fd) */ if (prevPtr == NULL) { - notifier.firstFileHandlerPtr = filePtr->nextPtr; + tsdPtr->firstFileHandlerPtr = filePtr->nextPtr; } else { prevPtr->nextPtr = filePtr->nextPtr; } @@ -366,9 +523,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,7 +539,8 @@ FileHandlerEventProc(evPtr, flags) * while the event is queued without leaving a dangling pointer. */ - for (filePtr = notifier.firstFileHandlerPtr; filePtr != NULL; + tsdPtr = TCL_TSD_INIT(&dataKey); + for (filePtr = tsdPtr->firstFileHandlerPtr; filePtr != NULL; filePtr = filePtr->nextPtr) { if (filePtr->fd != fileEvPtr->fd) { continue; @@ -435,11 +594,14 @@ 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 + Tcl_Time polltime; + 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 +613,96 @@ 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; + write(triggerPipe, "", 1); + } + + memset((VOID *) tsdPtr->readyMasks, 0, 3*MASK_SIZE*sizeof(fd_mask)); + + TclpConditionWait(&tsdPtr->waitCV, ¬ifierMutex, timePtr); + + if (waitForFiles && tsdPtr->onList) { + /* + * Remove the ThreadSpecificData structure of this thread from the + * waiting list. Don't bother to alert the notifier thread since + * we haven't added anything and it will notice the next time it + * wakes up. + */ + + 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; + } + + +#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 +710,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); + 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 +752,199 @@ 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. + */ + + TclpConditionNotify(¬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)) { + TclpConditionNotify(&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; + TclpConditionNotify(¬ifierCV); + Tcl_MutexUnlock(¬ifierMutex); +} +#endif diff --git a/unix/tclUnixPipe.c b/unix/tclUnixPipe.c index 83aa4e8..5c9cd18 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. * - * SCCS: @(#) tclUnixPipe.c 1.37 97/10/31 17:23:37 + * SCCS: @(#) tclUnixPipe.c 1.42 97/12/22 19:41:57 */ #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 186de21..8d3885b 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. * - * SCCS: @(#) tclUnixPort.h 1.49 97/07/30 14:11:59 + * SCCS: @(#) tclUnixPort.h 1.56 98/02/18 13:59:57 */ #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 @@ -40,11 +48,11 @@ #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 +63,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 +78,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 +112,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,30 +155,6 @@ #endif /* - * The following defines denote malloc and free as the system calls - * used to allocate new memory. These defines are only used in the - * file tclCkalloc.c. - */ - -#define TclpAlloc(size) malloc(size) -#define TclpFree(ptr) free(ptr) -#define TclpRealloc(ptr, size) realloc(ptr, size) - -/* - * The default platform eol translation on Unix is TCL_TRANSLATE_LF: - */ - -#define TCL_PLATFORM_TRANSLATION TCL_TRANSLATE_LF - -/* - * Not all systems declare the errno variable in errno.h. so this - * file does it explicitly. The list of system error messages also - * isn't generally declared in a header file anywhere. - */ - -extern int errno; - -/* * The type of the status returned by wait varies from UNIX system * to UNIX system. The macro below defines it: */ @@ -235,21 +218,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 @@ -305,7 +285,7 @@ EXTERN int gettimeofday _ANSI_ARGS_((struct timeval *tp, */ #ifndef S_IFLNK -# define lstat stat +# define lstat stat #endif /* @@ -429,23 +409,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. - */ -#define TclPlatformExit(status) exit(status) - -/* - * The following functions always succeeds under Unix. + * 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 TclHasSockets(interp) (TCL_OK) -#define TclHasPipes() (1) +extern int errno; /* * Variables provided by the C library: */ #if defined(_sgi) || defined(__sgi) -#define environ _environ +# define environ _environ #endif extern char **environ; @@ -460,15 +436,48 @@ extern char **environ; extern double strtod(); /* + *--------------------------------------------------------------------------- + * The following macros and declarations represent the interface between + * generic and unix-specific parts of Tcl. Some of the macros may override + * functions declared in tclInt.h. + *--------------------------------------------------------------------------- + */ + +/* + * The default platform eol translation on Unix is TCL_TRANSLATE_LF. + */ + +#define TCL_PLATFORM_TRANSLATION TCL_TRANSLATE_LF + +/* * The following macros define time related functions in terms of * standard Unix routines. */ -#define TclpGetDate(t,u) ((u) ? gmtime((t)) : localtime((t))) -#define TclStrftime(s,m,f,t) (strftime((s),(m),(f),(t))) -#define TclpGetPid(pid) ((unsigned long) (pid)) +#define TclpGetDate(t,u) ((u) ? gmtime((t)) : localtime((t))) +#define TclStrftime(s,m,f,t) (strftime((s),(m),(f),(t))) + +/* + * The following macros have trivial definitions, allowing generic code to + * address platform-specific issues. + */ + +#define TclpCheckStackSpace() (1) +#define TclpGetPid(pid) ((unsigned long) (pid)) +#define TclpHasSockets(interp) (TCL_OK) +#define TclpReleaseFile(file) /* Nothing. */ + +/* + * The following macros and declaration wrap the C runtime library + * functions. + */ + +#define TclpExit exit -#define TclpReleaseFile(file) +EXTERN int TclpLstat _ANSI_ARGS_((CONST char *path, + struct stat *buf)); +EXTERN int TclpStat _ANSI_ARGS_((CONST char *path, + struct stat *buf)); /* * The following routine is only exported for testing purposes. @@ -477,4 +486,24 @@ extern double strtod(); EXTERN int TclUnixWaitForFile _ANSI_ARGS_((int fd, int mask, int timeout)); +/* + * 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 */ + #endif /* _TCLUNIXPORT */ diff --git a/unix/tclUnixSock.c b/unix/tclUnixSock.c index c532993..703dc38 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. * - * SCCS: @(#) tclUnixSock.c 1.9 97/10/09 18:24:49 + * SCCS: @(#) tclUnixSock.c 1.11 98/02/19 11:52:09 */ #include "tcl.h" @@ -41,6 +41,8 @@ static char hostname[TCL_HOSTNAME_LEN + 1]; static int hostnameInited = 0; +static Tcl_Mutex hostMutex; + /* *---------------------------------------------------------------------- @@ -66,35 +68,45 @@ Tcl_GetHostName() #ifndef NO_UNAME struct utsname u; struct hostent *hp; +#else + char buffer[sizeof(hostname)]; #endif + 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; } diff --git a/unix/tclUnixTest.c b/unix/tclUnixTest.c index b1d1676..8163f58 100644 --- a/unix/tclUnixTest.c +++ b/unix/tclUnixTest.c @@ -3,12 +3,12 @@ * * Contains platform specific test commands for the Unix platform. * - * Copyright (c) 1996 Sun Microsystems, Inc. + * Copyright (c) 1996-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tclUnixTest.c 1.5 97/10/31 17:23:42 + * SCCS: @(#) tclUnixTest.c 1.6 97/11/07 21:31:30 */ #include "tclInt.h" @@ -165,7 +165,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 \"", @@ -247,7 +247,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 \"", @@ -256,7 +256,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); diff --git a/unix/tclUnixThrd.c b/unix/tclUnixThrd.c new file mode 100644 index 0000000..12ea5bb --- /dev/null +++ b/unix/tclUnixThrd.c @@ -0,0 +1,717 @@ +/* + * tclUnixThrd.c -- + * + * This file implements the UNIX-specific thread support. + * + * Copyright (c) 1991-1994 The Regents of the University of California. + * Copyright (c) 1994-1997 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclUnixThrd.c 1.18 98/02/19 14:24:12 + */ + +#include "tclInt.h" + +#ifdef TCL_THREADS + +#include "tclPort.h" +#include "pthread.h" + +/* + * masterLock is used to serialize creation of mutexes, condition + * variables, and thread local storage. + * This is the only place that can count on the ability to statically + * initialize the mutex. + */ + +static pthread_mutex_t masterLock = PTHREAD_MUTEX_INITIALIZER; + +/* + * initLock is used to serialize initialization and finalization + * of Tcl. It cannot use any dyamically allocated storage. + */ + +static pthread_mutex_t initLock = PTHREAD_MUTEX_INITIALIZER; + +/* + * allocLock is used to serialize memory allocation. + */ + +static pthread_mutex_t allocLock = PTHREAD_MUTEX_INITIALIZER; +static Tcl_Mutex allocMutex; + +/* + * 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 */ + + +/* + *---------------------------------------------------------------------- + * + * TclpMutexBootstrap -- + * + * This procedure gives out a pointer to a pre-allocated mutex. + * This is used by memory allocators for their own mutex. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_Mutex * +TclpMutexBootstrap() +{ +#ifdef TCL_THREADS + pthread_mutex_init(&allocLock, NULL); + allocMutex = (Tcl_Mutex)&allocLock; + return &allocMutex; +#else + return NULL; +#endif +} + +#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; + } +} + + +/* + *---------------------------------------------------------------------- + * + * TclpConditionWait -- + * + * 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 +TclpConditionWait(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); + } +} + +/* + *---------------------------------------------------------------------- + * + * TclpConditionNotify -- + * + * 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 +TclpConditionNotify(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 ba8d984..c94166d 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. * - * SCCS: @(#) tclUnixTime.c 1.13 97/10/31 15:04:58 + * SCCS: @(#) tclUnixTime.c 1.14 98/02/19 11:52:08 */ #include "tclInt.h" @@ -165,12 +165,15 @@ TclpGetTimeZone (currentTime) #if defined(HAVE_TIMEZONE_VAR) && !defined (TCL_GOT_TIMEZONE) # define TCL_GOT_TIMEZONE static int setTZ = 0; + static Tcl_Mutex tzMutex; int timeZone; + Tcl_MutexLock(&tzMutex); if (!setTZ) { tzset(); setTZ = 1; } + Tcl_MutexUnlock(&tzMutex); /* * Note: this is not a typo in "timezone" below! See tzset diff --git a/unix/tclXtTest.c b/unix/tclXtTest.c index 1479412..069003f 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. * - * SCCS: @(#) tclXtTest.c 1.2 97/09/15 15:26:52 + * SCCS: @(#) tclXtTest.c 1.3 97/11/06 15:16:16 */ #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. |