tclx8.4-8.4.1.orig/0000755000000000000000000000000012046525461010562 5ustar tclx8.4-8.4.1.orig/license.terms0000644000000000000000000000055512046313170013255 0ustar Extended Tcl was designed and implemented by Karl Lehenbauer (karl at procplace.com) and Mark Diekhans (markd at Kermodei.com), with help in the earliest stages from Peter da Silva (peter at NeoSoft.com). TclX 8.4 work was done by Jeff Hobbs. As with Tcl, all of Extended Tcl is freely redistributable, including for commercial use and resale (BSD-style license). tclx8.4-8.4.1.orig/Makefile.in0000644000000000000000000004120712046313234012624 0ustar # Makefile.in -- # # This file is a Makefile for Sample TEA Extension. If it has the name # "Makefile.in" then it is a template for a Makefile; to generate the # actual Makefile, run "./configure", which is a configuration script # generated by the "autoconf" program (constructs like "@foo@" will get # replaced in the actual Makefile. # # Copyright (c) 1999 Scriptics Corporation. # Copyright (c) 2002-2005 ActiveState Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # RCS: @(#) $Id: Makefile.in,v 1.17 2005/11/20 21:29:13 hobbs Exp $ #======================================================================== # Edit the following few lines when writing a new extension #======================================================================== #======================================================================== # Enumerate the names of the source files included in this package. # This will be used when a dist target is added to the Makefile. # EXTRA_SOURCES will be replaced by WIN_SOURCES or UNIX_SOURCES, as is # appropriate for your platform. It is not important to specify the # directory, as long as it is the $(srcdir) or in the generic, win or # unix subdirectory. #======================================================================== PKG_SOURCES = @PKG_SOURCES@ PKG_OBJECTS = @PKG_OBJECTS@ @LIBOBJS@ #======================================================================== # Identify the object files. This replaces .c with .$(OBJEXT) for all # the named source files. These objects are created and linked into the # final library. In these do not correspond directly to the source files # above, you will need to enumerate the object files here. # Normally we would use $(OBJEXT), but certain make executables won't do # the extra macro in a macro conversion properly. # # "tclx_LIB_FILE" refers to the library (dynamic or static as per # configuration options) composed of the named objects. #======================================================================== TEST_OBJS = tclXunixTest.$(OBJEXT) #======================================================================== # PKG_TCL_SOURCES identifies Tcl runtime files that are associated with # this package that need to be installed, if any. #======================================================================== PKG_TCL_SOURCES = @PKG_TCL_SOURCES@ #======================================================================== # This is a list of public header files to be installed, if any. #======================================================================== PKG_HEADERS = @PKG_HEADERS@ #======================================================================== # Add additional lines to handle any additional AC_SUBST cases that # have been added to the configure script. #======================================================================== HELP_DIR = @HELP_DIR@ HELP_DIR_NATIVE = `@CYGPATH@ ${HELP_DIR}` #======================================================================== # Nothing of the variables below this line need to be changed. Please # check the TARGETS section below to make sure the make targets are # correct. #======================================================================== #======================================================================== # "PKG_LIB_FILE" refers to the library (dynamic or static as per # configuration options) composed of the named objects. #======================================================================== PKG_LIB_FILE = @PKG_LIB_FILE@ lib_BINARIES = $(PKG_LIB_FILE) BINARIES = $(lib_BINARIES) SHELL = @SHELL@ srcdir = @srcdir@ prefix = @prefix@ exec_prefix = @exec_prefix@ bindir = @bindir@ libdir = @libdir@ datadir = @datadir@ mandir = @mandir@ includedir = @includedir@ DESTDIR = PKG_DIR = $(PACKAGE_NAME)$(PACKAGE_VERSION) pkgdatadir = $(datadir)/$(PKG_DIR) pkglibdir = $(libdir)/$(PKG_DIR) pkgincludedir = $(includedir)/$(PKG_DIR) top_builddir = . INSTALL = @INSTALL@ INSTALL_PROGRAM = @INSTALL_PROGRAM@ INSTALL_DATA = @INSTALL_DATA@ INSTALL_SCRIPT = @INSTALL_SCRIPT@ PACKAGE_NAME = @PACKAGE_NAME@ PACKAGE_VERSION = @PACKAGE_VERSION@ CC = @CC@ CFLAGS_DEFAULT = @CFLAGS_DEFAULT@ CFLAGS_WARNING = @CFLAGS_WARNING@ CLEANFILES = @CLEANFILES@ EXEEXT = @EXEEXT@ LDFLAGS_DEFAULT = @LDFLAGS_DEFAULT@ MAKE_LIB = @MAKE_LIB@ MAKE_SHARED_LIB = @MAKE_SHARED_LIB@ MAKE_STATIC_LIB = @MAKE_STATIC_LIB@ MAKE_STUB_LIB = @MAKE_STUB_LIB@ OBJEXT = @OBJEXT@ RANLIB = @RANLIB@ RANLIB_STUB = @RANLIB_STUB@ SHLIB_CFLAGS = @SHLIB_CFLAGS@ SHLIB_LD = @SHLIB_LD@ SHLIB_LD_LIBS = @SHLIB_LD_LIBS@ STLIB_LD = @STLIB_LD@ TCL_DEFS = @TCL_DEFS@ TCL_BIN_DIR = @TCL_BIN_DIR@ TCL_SRC_DIR = @TCL_SRC_DIR@ # This is necessary for packages that use private Tcl headers TCL_TOP_DIR_NATIVE = @TCL_TOP_DIR_NATIVE@ # Not used, but retained for reference of what libs Tcl required TCL_LIBS = @TCL_LIBS@ #======================================================================== # TCLLIBPATH seeds the auto_path in Tcl's init.tcl so we can test our # package without installing. The other environment variables allow us # to test against an uninstalled Tcl. Add special env vars that you # require for testing here (like TCLX_LIBRARY). #======================================================================== EXTRA_PATH = $(top_builddir):$(TCL_BIN_DIR) TCLSH_ENV = TCL_LIBRARY=`@CYGPATH@ $(TCL_SRC_DIR)/library` \ TCLX_LIBRARY=`@CYGPATH@ $(srcdir)/library` \ TCLX_HELP_DIR="$(HELP_DIR_NATIVE)" \ @LD_LIBRARY_PATH_VAR@="$(EXTRA_PATH):$(@LD_LIBRARY_PATH_VAR@)" \ PATH="$(EXTRA_PATH):$(PATH)" \ TCLLIBPATH="$(top_builddir)" TCLSH_PROG = @TCLSH_PROG@ TCLSH = $(TCLSH_ENV) $(TCLSH_PROG) SHARED_BUILD = @SHARED_BUILD@ TCLX_TOOLS_SRC_DIR = `@CYGPATH@ $(srcdir)/unix/tools` TCLX_DOC_DIR = `@CYGPATH@ $(srcdir)/doc` TCLX_INSTCOPY = ${TCLSH} ${TCLX_TOOLS_SRC_DIR}/instcopy.tcl TCLX_HELP_INST_DIR = `@CYGPATH@ $(DESTDIR)$(pkglibdir)/help` INCLUDES = @PKG_INCLUDES@ @TCL_INCLUDES@ PKG_CFLAGS = @PKG_CFLAGS@ DEFS = @DEFS@ $(PKG_CFLAGS) CONFIG_CLEAN_FILES = Makefile CPPFLAGS = @CPPFLAGS@ LIBS = @PKG_LIBS@ @LIBS@ AR = @AR@ CFLAGS = @CFLAGS@ COMPILE = $(CC) $(DEFS) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) #======================================================================== # Start of user-definable TARGETS section #======================================================================== #======================================================================== # TEA TARGETS. Please note that the "libraries:" target refers to platform # independent files, and the "binaries:" target inclues executable programs and # platform-dependent libraries. Modify these targets so that they install # the various pieces of your package. The make and install rules # for the BINARIES that you specified above have already been done. #======================================================================== all: binaries libraries doc #======================================================================== # The binaries target builds executable programs, Windows .dll's, unix # shared/static libraries, and any other platform-dependent files. # The list of targets to build for "binaries:" is specified at the top # of the Makefile, in the "BINARIES" variable. #======================================================================== binaries: $(BINARIES) pkgIndex.tcl libraries: doc: @BUILDHELP@ install: all install-binaries install-libraries install-doc install-binaries: binaries install-lib-binaries install-bin-binaries #======================================================================== # This rule installs platform-independent files, such as header files. #======================================================================== install-libraries: libraries @mkdir -p $(DESTDIR)$(includedir) @echo "Installing header files in $(DESTDIR)$(includedir)" @list='$(PKG_HEADERS)'; for i in $$list; do \ echo "Installing $(srcdir)/$$i" ; \ $(INSTALL_DATA) $(srcdir)/$$i $(DESTDIR)$(includedir) ; \ done; #======================================================================== # Install documentation. Unix manpages should go in the $(mandir) # directory. #======================================================================== install-doc: doc install-help @mkdir -p $(DESTDIR)$(mandir)/mann @echo "Installing documentation in $(DESTDIR)$(mandir)" @list='$(srcdir)/doc/*.n'; for i in $$list; do \ echo "Installing $$i"; \ rm -f $(DESTDIR)$(mandir)/mann/`basename $$i`; \ $(INSTALL_DATA) $$i $(DESTDIR)$(mandir)/mann ; \ done test: binaries libraries $(TCLSH) `@CYGPATH@ $(srcdir)/tests/all.tcl` $(TESTFLAGS) shell: binaries libraries @$(TCLSH) $(SCRIPT) GDB = gdb gdb: $(TCLSH_ENV) $(GDB) $(TCLSH_PROG) $(SCRIPT) #VALGRINDFLAGS=--logfile-fd=9 #TESTFLAGS=9> valgrind.log valgrindtest: binaries libraries $(TCLSH_ENV) valgrind --num-callers=12 --leak-resolution=high -v --leak-check=yes --show-reachable=yes $(VALGRINDFLAGS) $(TCLSH_PROG) `@CYGPATH@ $(srcdir)/tests/all.tcl` $(TESTFLAGS) valgrind: binaries libraries $(TCLSH_ENV) valgrind --num-callers=12 --leak-resolution=high -v --leak-check=yes --show-reachable=yes $(VALGRINDFLAGS) $(TCLSH_PROG) $(SCRIPT) depend: #======================================================================== # $(PKG_LIB_FILE) should be listed as part of the BINARIES variable # mentioned above. That will ensure that this target is built when you # run "make binaries". # # The $(PKG_OBJECTS) objects are created and linked into the final # library. In most cases these object files will correspond to the # source files above. #======================================================================== $(PKG_LIB_FILE): $(PKG_OBJECTS) -rm -f $(PKG_LIB_FILE) ${MAKE_LIB} $(RANLIB) $(PKG_LIB_FILE) pkgIndex.tcl: (echo 'package ifneeded Tclx $(PACKAGE_VERSION) \ [list load [file join $$dir $(PKG_LIB_FILE)] Tclx]'\ ) > pkgIndex.tcl #======================================================================== # We need to enumerate the list of .c to .o lines here. # # In the following lines, $(srcdir) refers to the toplevel directory # containing your extension. If your sources are in a subdirectory, # you will have to modify the paths to reflect this: # # sample.$(OBJEXT): $(srcdir)/generic/sample.c # $(COMPILE) -c `@CYGPATH@ $(srcdir)/generic/sample.c` -o $@ # # Setting the VPATH variable to a list of paths will cause the # makefile to look into these paths when resolving .c to .obj # dependencies. #======================================================================== VPATH = $(srcdir):$(srcdir)/generic:$(srcdir)/unix:$(srcdir)/win:$(srcdir)/compat .c.@OBJEXT@: $(COMPILE) -c `@CYGPATH@ $<` -o $@ #======================================================================== # Distribution creation # You may need to tweak this target to make it work correctly. #======================================================================== #COMPRESS = tar cvf $(PKG_DIR).tar $(PKG_DIR); compress $(PKG_DIR).tar COMPRESS = tar jcvf $(PKG_DIR).tar.bz2 $(PKG_DIR) DIST_ROOT = /tmp/dist DIST_DIR = $(DIST_ROOT)/$(PKG_DIR) dist-clean: rm -rf $(DIST_DIR) $(DIST_ROOT)/$(PKG_DIR).tar.* dist: dist-clean mkdir -p $(DIST_DIR) cp -p $(srcdir)/ChangeLog $(srcdir)/README* $(srcdir)/license* \ $(srcdir)/aclocal.m4 $(srcdir)/configure $(srcdir)/*.in \ $(DIST_DIR)/ chmod 664 $(DIST_DIR)/Makefile.in $(DIST_DIR)/aclocal.m4 chmod 775 $(DIST_DIR)/configure $(DIST_DIR)/configure.in mkdir $(DIST_DIR)/tclconfig cp $(srcdir)/tclconfig/install-sh $(srcdir)/tclconfig/tcl.m4 \ $(DIST_DIR)/tclconfig/ chmod 664 $(DIST_DIR)/tclconfig/tcl.m4 chmod +x $(DIST_DIR)/tclconfig/install-sh list='doc generic library tests tests/compat unix unix/tools win'; \ for p in $$list; do \ if test -d $(srcdir)/$$p ; then \ mkdir $(DIST_DIR)/$$p; \ cp -p $(srcdir)/$$p/*.* $(DIST_DIR)/$$p/; \ fi; \ done cp -p $(srcdir)/unix/INSTALL $(DIST_DIR)/unix/; cp -p $(srcdir)/unix/tools/*manpages $(DIST_DIR)/unix/tools/; (cd $(DIST_ROOT); $(COMPRESS);) #======================================================================== # End of user-definable section #======================================================================== #======================================================================== # Don't modify the file to clean here. Instead, set the "CLEANFILES" # variable in configure.in #======================================================================== clean: helpclean -test -z "$(BINARIES)" || rm -f $(BINARIES) -rm -f *.$(OBJEXT) core *.core -test -z "$(CLEANFILES)" || rm -f $(CLEANFILES) helpclean: -rm -rf $(HELP_DIR) distclean: clean -rm -f *.tab.c -rm -f $(CONFIG_CLEAN_FILES) -rm -f config.cache config.log config.status #======================================================================== # Install binary object libraries. On Windows this includes both .dll and # .lib files. Because the .lib files are not explicitly listed anywhere, # we need to deduce their existence from the .dll file of the same name. # Library files go into the lib directory. # In addition, this will generate the pkgIndex.tcl # file in the install location (assuming it can find a usable tclsh shell) # # You should not have to modify this target. #======================================================================== install-lib-binaries: @mkdir -p $(DESTDIR)$(pkglibdir) @list='$(lib_BINARIES)'; for p in $$list; do \ if test -f $$p; then \ echo " $(INSTALL_PROGRAM) $$p $(DESTDIR)$(pkglibdir)/$$p"; \ $(INSTALL_PROGRAM) $$p $(DESTDIR)$(pkglibdir)/$$p; \ stub=`echo $$p|sed -e "s/.*\(stub\).*/\1/"`; \ if test "x$$stub" = "xstub"; then \ echo " $(RANLIB_STUB) $(DESTDIR)$(pkglibdir)/$$p"; \ $(RANLIB_STUB) $(DESTDIR)$(pkglibdir)/$$p; \ else \ echo " $(RANLIB) $(DESTDIR)$(pkglibdir)/$$p"; \ $(RANLIB) $(DESTDIR)$(pkglibdir)/$$p; \ fi; \ ext=`echo $$p|sed -e "s/.*\.//"`; \ if test "x$$ext" = "xdll"; then \ lib=`basename $$p|sed -e 's/.[^.]*$$//'`.lib; \ if test -f $$lib; then \ echo " $(INSTALL_DATA) $$lib $(DESTDIR)$(pkglibdir)/$$lib"; \ $(INSTALL_DATA) $$lib $(DESTDIR)$(pkglibdir)/$$lib; \ fi; \ fi; \ fi; \ done @list='$(PKG_TCL_SOURCES)'; for p in $$list; do \ if test -f $(srcdir)/$$p; then \ destp=`basename $$p`; \ echo " Install $$destp $(DESTDIR)$(pkglibdir)/$$destp"; \ $(INSTALL_DATA) $(srcdir)/$$p $(DESTDIR)$(pkglibdir)/$$destp; \ fi; \ done @if test "x$(SHARED_BUILD)" = "x1"; then \ echo " Install pkgIndex.tcl $(DESTDIR)$(pkglibdir)"; \ $(INSTALL_DATA) pkgIndex.tcl $(DESTDIR)$(pkglibdir); \ fi #======================================================================== # Install binary executables (e.g. .exe files and dependent .dll files) # This is for files that must go in the bin directory (located next to # wish and tclsh), like dependent .dll files on Windows. # # You should not have to modify this target, except to define bin_BINARIES # above if necessary. #======================================================================== install-bin-binaries: @mkdir -p $(DESTDIR)$(bindir) @list='$(bin_BINARIES)'; for p in $$list; do \ if test -f $$p; then \ echo " $(INSTALL_PROGRAM) $$p $(DESTDIR)$(bindir)/$$p"; \ $(INSTALL_PROGRAM) $$p $(DESTDIR)$(bindir)/$$p; \ fi; \ done .SUFFIXES: .c .$(OBJEXT) Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status cd $(top_builddir) \ && CONFIG_FILES=$@ CONFIG_HEADERS= $(SHELL) ./config.status uninstall-binaries: list='$(lib_BINARIES)'; for p in $$list; do \ rm -f $(DESTDIR)$(pkglibdir)/$$p; \ done list='$(PKG_TCL_SOURCES)'; for p in $$list; do \ p=`basename $$p`; \ rm -f $(DESTDIR)$(pkglibdir)/$$p; \ done list='$(bin_BINARIES)'; for p in $$list; do \ rm -f $(DESTDIR)$(bindir)/$$p; \ done .PHONY: all binaries clean depend distclean doc install libraries test # Tell versions [3.59,3.63) of GNU make to not export all variables. # Otherwise a system limit (for SysV at least) may be exceeded. .NOEXPORT: #------------------------------------------------------------------------------ # Build help for Tcl & TclX. These files are normally part of the # distribution and not rebuilt by users. # buildhelp: help help: $(BINARIES) if test ! -d "${HELP_DIR}" ; then \ mkdir -p "${HELP_DIR}" ; \ ${TCLSH} ${TCLX_TOOLS_SRC_DIR}/bldmanhelp.tcl \ `@CYGPATH@ ${TCL_SRC_DIR}/doc` \ ${TCLX_TOOLS_SRC_DIR}/tclmanpages ${HELP_DIR_NATIVE} Tcl.brf; \ ${TCLSH} ${TCLX_TOOLS_SRC_DIR}/runbuildhelp.tcl \ ${HELP_DIR_NATIVE} TclX.brf ${TCLX_DOC_DIR}/TclX.n; \ fi install-help: @if test -d "${HELP_DIR}" ; then \ echo "Installing TclX help files in ${TCLX_HELP_INST_DIR}"; \ mkdir -p ${TCLX_HELP_INST_DIR}; \ ${TCLX_INSTCOPY} ${HELP_DIR_NATIVE} ${TCLX_HELP_INST_DIR}; \ fi tclx8.4-8.4.1.orig/aclocal.m40000644000000000000000000000022312046313166012414 0ustar # # Include the TEA standard macro set # builtin(include,tclconfig/tcl.m4) # # Add here whatever m4 macros you want to define for your package # tclx8.4-8.4.1.orig/configure.in0000755000000000000000000003445612046525320013104 0ustar #!/bin/bash -norc dnl This file is an input file used by the GNU "autoconf" program to dnl generate the file "configure", which is run during Tcl installation dnl to configure the system for the local environment. # # RCS: @(#) $Id: configure.in,v 1.18 2012/11/07 18:39:12 andreas_kupries Exp $ AC_INIT([tclx], [8.4]) FULL_VERSION="8.4.1" TEA_INIT([3.5]) AC_CONFIG_AUX_DIR(tclconfig) AC_DEFINE_UNQUOTED(FULL_VERSION, "${FULL_VERSION}") #-------------------------------------------------------------------- # Load the tclConfig.sh file #-------------------------------------------------------------------- TEA_PATH_TCLCONFIG TEA_LOAD_TCLCONFIG #----------------------------------------------------------------------- # Handle the --prefix=... option by defaulting to what Tcl gave. # Must be called after TEA_LOAD_TCLCONFIG and before TEA_SETUP_COMPILER. #----------------------------------------------------------------------- TEA_PREFIX #----------------------------------------------------------------------- # Standard compiler checks. # This sets up CC by using the CC env var, or looks for gcc otherwise. # This also calls AC_PROG_CC, AC_PROG_INSTALL and a few others to create # the basic setup necessary to compile executables. #----------------------------------------------------------------------- TEA_SETUP_COMPILER TEA_ADD_SOURCES([ tclXbsearch.c tclXchmod.c tclXcmdloop.c tclXdebug.c tclXdup.c tclXfcntl.c tclXfilecmds.c tclXfilescan.c tclXflock.c tclXfstat.c tclXgeneral.c tclXhandles.c tclXinit.c tclXkeylist.c tclXlib.c tclXlist.c tclXmath.c tclXmsgcat.c tclXprocess.c tclXprofile.c tclXselect.c tclXsignal.c tclXstring.c tclXsocket.c tclXutil.c tclXoscmds.c tclXlgets.c ]) TEA_ADD_HEADERS([generic/tclExtend.h]) TEA_ADD_INCLUDES([-I\"`${CYGPATH} ${srcdir}/generic`\"]) TEA_ADD_LIBS([]) TEA_ADD_CFLAGS([]) TEA_ADD_STUB_SOURCES([]) TEA_ADD_TCL_SOURCES([ library/tclx.tcl library/autoload.tcl library/arrayprocs.tcl library/compat.tcl library/convlib.tcl library/edprocs.tcl library/events.tcl library/forfile.tcl library/globrecur.tcl library/help.tcl library/profrep.tcl library/pushd.tcl library/setfuncs.tcl library/showproc.tcl library/stringfile.tcl library/tcllib.tcl library/fmath.tcl library/buildhelp.tcl ]) #-------------------------------------------------------------------- # Choose which headers you need. Extension authors should try very # hard to only rely on the Tcl public header files. Internal headers # contain private data structures and are subject to change without # notice. # This MUST be called after TEA_LOAD_TCLCONFIG / TEA_LOAD_TKCONFIG #-------------------------------------------------------------------- #TEA_PUBLIC_TCL_HEADERS TEA_PRIVATE_TCL_HEADERS #-------------------------------------------------------------------- # __CHANGE__ # A few miscellaneous platform-specific items: # # Define a special symbol for Windows (BUILD_tclx in this case) so # that we create the export library with the dll. See sha1.h on how # to use this. # # Windows creates a few extra files that need to be cleaned up. # You can add more files to clean if your extension creates any extra # files. # # Define any extra compiler flags in the PACKAGE_CFLAGS variable. # These will be appended to the current set of compiler flags for # your system. #-------------------------------------------------------------------- if test "${TEA_PLATFORM}" = "windows" ; then AC_DEFINE(BUILD_tclx) CLEANFILES="pkgIndex.tcl *.lib *.dll *.exp *.ilk *.pdb vc*.pch" TEA_ADD_SOURCES([tclXwinCmds.c tclXwinDup.c tclXwinId.c tclXwinOS.c]) TEA_ADD_LIBS([wsock32.lib]) TEA_ADD_INCLUDES([-I\"`${CYGPATH} ${srcdir}/win`\"]) else CLEANFILES="pkgIndex.tcl" TEA_ADD_SOURCES([tclXunixCmds.c tclXunixDup.c tclXunixId.c tclXunixOS.c tclXunixSock.c]) TEA_ADD_LIBS([${MATH_LIBS}]) TEA_ADD_INCLUDES([-I\"${srcdir}/unix\"]) fi AC_SUBST(CLEANFILES) #-------------------------------------------------------------------- # Check whether --enable-threads or --disable-threads was given. #-------------------------------------------------------------------- TEA_ENABLE_THREADS #-------------------------------------------------------------------- # The statement below defines a collection of symbols related to # building as a shared library instead of a static library. #-------------------------------------------------------------------- TEA_ENABLE_SHARED #-------------------------------------------------------------------- # This macro figures out what flags to use with the compiler/linker # when building shared/static debug/optimized objects. This information # can be taken from the tclConfig.sh file, but this figures it all out. #-------------------------------------------------------------------- TEA_CONFIG_CFLAGS #-------------------------------------------------------------------- # Set the default compiler switches based on the --enable-symbols option. #-------------------------------------------------------------------- TEA_ENABLE_SYMBOLS #-------------------------------------------------------------------- # Everyone should be linking against the Tcl stub library. If you # can't for some reason, remove this definition. If you aren't using # stubs, you also need to modify the SHLIB_LD_LIBS setting below to # link against the non-stubbed Tcl library. Add Tk too if necessary. #-------------------------------------------------------------------- AC_DEFINE(USE_TCL_STUBS) #-------------------------------------------------------------------- # START Special case checks #-------------------------------------------------------------------- if test "${TEA_PLATFORM}" = "unix" ; then #------------------------------------------------------------------------- # Check for system header files. #------------------------------------------------------------------------- AC_CHECK_HEADER(sys/select.h, [AC_DEFINE(HAVE_SYS_SELECT_H)], ) #------------------------------------------------------------------------- # What type do signals return? #------------------------------------------------------------------------- AC_TYPE_SIGNAL #------------------------------------------------------------------------- # Find out all about time handling differences. #------------------------------------------------------------------------- TEA_TIME_HANDLER #-------------------------------------------------------------------- # The check below checks whether defines the type # "union wait" correctly. It's needed because of weirdness in # HP-UX where "union wait" is defined in both the BSD and SYS-V # environments. Checking the usability of WIFEXITED seems to do # the trick. #-------------------------------------------------------------------- AC_MSG_CHECKING([union wait]) AC_CACHE_VAL(tcl_cv_union_wait, AC_TRY_LINK([#include #include ], [ union wait x; WIFEXITED(x); /* Generates compiler error if WIFEXITED uses an int. */ ], tcl_cv_union_wait=yes, tcl_cv_union_wait=no)) AC_MSG_RESULT($tcl_cv_union_wait) if test $tcl_cv_union_wait = no; then AC_DEFINE(NO_UNION_WAIT) fi #------------------------------------------------------------------------- # Test to see if "times" returns a status or the amount of elapsed real # time. #------------------------------------------------------------------------- AC_MSG_CHECKING(checking to see what 'times' returns) AC_TRY_RUN([ #include #include main() { struct tms cpu; times(&cpu); sleep(2); exit ((times(&cpu) > 0) ? 0 : 1); } ], [AC_MSG_RESULT(elapsed real time)], [AC_MSG_RESULT(a status) AC_DEFINE(TIMES_RETS_STATUS)], [AC_MSG_ERROR(cross-compiling not supported)]) #------------------------------------------------------------------------- # Check for missing typedefs. #------------------------------------------------------------------------- #AC_CHECK_TYPE(clock_t, long) AC_CHECK_TYPE(time_t, long) AC_TYPE_OFF_T #------------------------------------------------------------------------- # Older SCO systems don't have ftruncate, but have chsize in libx. Newer # versions have both. Only check for chsize in libx if we don't have # truncate. #------------------------------------------------------------------------- AC_CHECK_FUNC(ftruncate, , [AC_DEFINE(NO_FTRUNCATE) AC_CHECK_LIB(x, chsize, [AC_DEFINE(HAVE_CHSIZE) TEA_ADD_LIBS([-lx])])]) #------------------------------------------------------------------------- # Check for various Unix or library functions that can be used by TclX. # These must be after the library checks. #------------------------------------------------------------------------- AC_CHECK_FUNC(select, , [AC_DEFINE(NO_SELECT)]) AC_CHECK_FUNC(setitimer, , [AC_DEFINE(NO_SETITIMER)]) AC_CHECK_FUNC(sigaction, , [AC_DEFINE(NO_SIGACTION)]) AC_CHECK_FUNC(setpgid, , [AC_DEFINE(NO_SETPGID)]) AC_CHECK_FUNC(getgroups, , [AC_DEFINE(NO_GETGROUPS)]) AC_CHECK_FUNC(bzero, , [AC_DEFINE(NO_BZERO)]) AC_CHECK_FUNC(bcopy, , [AC_DEFINE(NO_BCOPY)]) AC_CHECK_FUNC(fsync, , [AC_DEFINE(NO_FSYNC)]) AC_CHECK_FUNC(getpriority, , [AC_DEFINE(NO_GETPRIORITY)]) AC_CHECK_FUNC(strcoll, , [AC_DEFINE(NO_STRCOLL)]) AC_CHECK_FUNC(fchown, , [AC_DEFINE(NO_FCHOWN)]) AC_CHECK_FUNC(fchmod, , [AC_DEFINE(NO_FCHMOD)]) AC_CHECK_FUNC(truncate, , [AC_DEFINE(NO_TRUNCATE)]) AC_CHECK_FUNC(waitpid, , [AC_DEFINE(NO_WAITPID)]) AC_CHECK_FUNC(sysconf, , [AC_DEFINE(NO_SYSCONF)]) #------------------------------------------------------------------------- # Test for socket related functions. #------------------------------------------------------------------------- AC_CHECK_FUNC(inet_aton, , [AC_DEFINE(NO_INET_ATON)]) AC_CHECK_FUNC(gethostname, , [AC_DEFINE(NO_GETHOSTNAME)]) #------------------------------------------------------------------------- # Check for additional libraries the Tcl/Tk does not check for. #------------------------------------------------------------------------- # This is needed for DEC Alphas AC_CHECK_LIB(dnet_stub, main, [TEA_ADD_LIBS([-ldnet_stub])]) #------------------------------------------------------------------------- # Check for catgets. Not the some systems (NetBSD 1.0) have catclose # declared as type void rather than type int. #------------------------------------------------------------------------- AC_CHECK_FUNC(catgets, [AC_MSG_CHECKING([catclose return value]) AC_TRY_COMPILE([#include ], [ if (catclose ((nl_catd) 0) == 0) exit (0);], AC_MSG_RESULT(ok), [ AC_MSG_RESULT([broken catclose return type]) AC_DEFINE(BAD_CATCLOSE)])], [AC_DEFINE(NO_CATGETS)]) fi # end Unix only checks #------------------------------------------------------------------------------ # Check for missing functions that we need. Must be done after library checks. #------------------------------------------------------------------------------ dnl Disable the automake-friendly normalization of LIBOBJS ($U) dnl performed by autoconf 2.53 and later. It's not correct for us. AC_DEFUN([_AC_LIBOBJS_NORMALIZE],[]) AC_CHECK_FUNC(random, ,[AC_LIBOBJ([random])] AC_DEFINE(NO_RANDOM)) #------------------------------------------------------------------------------ # Determine if random is declared in stdlib.h or math.h. If it is, we don't # want to redeclare it. Some systems, such as the DEC Alpha, have random # declared as returning int rather than long, since long is 64 bit. #------------------------------------------------------------------------------ found_random=NO AC_HEADER_EGREP("random", stdlib.h, [found_random=YES]) AC_HEADER_EGREP("random", math.h, [found_random=YES]) if test "$found_random" = "NO"; then AC_DEFINE(NO_RANDOM_PROTO) fi #------------------------------------------------------------------------- # Allow --with-help to specify help file outputs #------------------------------------------------------------------------- AC_MSG_CHECKING([where to place TclX help files]) AC_ARG_WITH(help, [ --with-help directory containing generated help files], with_help=${withval}, with_help=no) HELP_DIR=`pwd`/help BUILDHELP= if test x"${with_help}" = x"no" ; then AC_MSG_RESULT([do not build help files]) else if test x"${with_help}" != x -a x"${with_help}" != x"yes" ; then # Ensure that we don't catch --with-help by itself HELP_DIR=${with_help} fi #------------------------------------------------------------------------- # Determine if we have enough tools to generate the help files. #------------------------------------------------------------------------- AC_MSG_RESULT([${HELP_DIR}]) AC_CHECK_PROG(NROFF, nroff, yes, no) AC_CHECK_PROG(COL, col, yes, no) if test "x${NROFF}" = "xno" -o "x${COL}" = "xno" ; then AC_MSG_WARN([nroff or col executable missing. Cannot build TclX help.]) else BUILDHELP=buildhelp fi fi AC_SUBST(BUILDHELP) AC_SUBST(HELP_DIR) #-------------------------------------------------------------------- # End of special case checks #-------------------------------------------------------------------- #-------------------------------------------------------------------- # This macro generates a line to use when building a library. It # depends on values set by the TEA_ENABLE_SHARED, TEA_ENABLE_SYMBOLS, # and TEA_LOAD_TCLCONFIG macros above. #-------------------------------------------------------------------- TEA_MAKE_LIB #-------------------------------------------------------------------- # Find tclsh so that we can run pkg_mkIndex to generate the pkgIndex.tcl # file during the install process. Don't run the TCLSH_PROG through # ${CYGPATH} because it's being used directly by make. # Require that we use a tclsh shell version 8.2 or later since earlier # versions have bugs in the pkg_mkIndex routine. # Add WISH as well if this is a Tk extension. #-------------------------------------------------------------------- TEA_PROG_TCLSH #-------------------------------------------------------------------- # Finally, substitute all of the various values into the Makefile. #-------------------------------------------------------------------- AC_OUTPUT([Makefile]) tclx8.4-8.4.1.orig/README0000644000000000000000000001506212046316343011443 0ustar Extended Tcl (TclX) 8.4.1 ========================= INTRODUCTION ============ Extended Tcl (TclX), is an extension to Tcl, the Tool Command Language invented by Dr. John Ousterhout. Tcl is a powerful, yet simple embeddable programming language. Extended Tcl is oriented towards system programming tasks and large application development. TclX provides additional interfaces to the operating system, and adds many new programming constructs, text manipulation tools, and debugging tools. TclX is upwardly compatible with Tcl. You take the Extended Tcl package, add it to Tcl, and from that you get Extended Tcl. Tcl can be obtained at http://www.tcl.tk/ or http://tcl.sourceforge.net/ Extended Tcl runs on most Unix-like systems and Windows. While this TclX distribution is tested with Tcl 8.4 and Tk 8.4, it should with Tcl 8.3+. Please check the Extended Tcl homepage at http://tclx.sourceforge.net/ for the latest release and information. Extended Tcl was designed and implemented by Karl Lehenbauer (karl@procplace.com) and Mark Diekhans (markd@Kermodei.com), with help in the earliest stages from Peter da Silva (peter@NeoSoft.com). TclX 8.4 work was done by Jeff Hobbs at ActiveState. TclX 8.4 differs from its predecessors in that it is based more on the idea of TclX as an extension to Tcl, and not an alternate environment. There is no TkX and no stand-alone shells are built. As with Tcl, all of Extended Tcl is freely redistributable, including for commercial use and resale (BSD-style license). BUILDING AND INSTALLING TCLX ============================ 1. Uncompress and unpack the distribution ON UNIX/MAC: gzip -cd tclx.tar.gz | tar xf - ON WINDOWS: use something like WinZip to unpack the archive. This will create a subdirectory tclx with all the files in it. 2. Configure ON UNIX/MAC: cd tclx ./configure TclX is TEA-based and uses information left in tclConfig.sh when you built tcl. This file will be found in $exec_prefix/lib/. You might set the --prefix and --exec-prefix options of configure if you don't want the default (/usr/local). If building on multiple unix platforms, the following is recommended to isolate build conflicts: mkdir / cd !$ /path/to/tclx/configure ON WINDOWS: TclX supports building in the cygwin/msys environment on Windows based on TEA (http://www.tcl.tk/doc/tea/). Inside this environment, you build the same as on Unix. Otherwise, hack makefile.vc until it works and compile. It was not updated for TclX 8.4. It has problems executing wish from a path with a space in it, but the DLL builds just fine. 3. Make and Install ON UNIX/MAC or WINDOWS with cygwin/msys: make make test (OPTIONAL) make install ON WINDOWS (makefile.vc): nmake -f makefile.vc nmake -f makefile.vc test (OPTIONAL) nmake -f makefile.vc install TclX is built to comply to the latest tcl package conventions. CHANGES IN TCLX 8.4 =================== o Restructure of the sources and build system o Removal of TkX extension FEATURES ADDED BY EXTENDED TCL ============================== Here is a summary of the features added by Extended Tcl. For more details on the commands and functionality provided by Extended Tcl, see the manual page man/TclX.man. o Keyed lists, a type of list that provides functionality similar to C structures. o A command tracing facility for debugging and a performance profiler. o Unix access commands provide access to many Unix system calls, including process management. o File control and status commands provide added facilities for accessing and manipulating open files. o File scanning facility that provides awk-like functionality. o Extended list manipulation commands. o Extended string and character manipulation commands. o X/PG based internationalization commands. o Advanced Tcl code library facility that is oriented towards building large applications. It is compatible with standard Tcl auto-loading. o Additional general programming commands. o Restricted use in a safe interpreter. o Support for binary data in most commands. MANUAL PAGES ============ Man pages in nroff/troff format are provided for all of Tcl and the extensions in the doc directory. Start with the TclX.n manual. EXTENDED TCL VERSION NAMING =========================== Extended Tcl version numbering has been changed to track the Tcl/Tk version numbering roughly. LINKING APPLICATIONS AND EXTENSION WITH TCLX ============================================ There are three basic approaches to linking TclX into applications or with other extensions: o Dynamically load the C code using either 'package require' or the 'load' command. o Linking TclX into an application based on the standard Tcl or Tk shells (tclsh or wish) or based on your own startup. See the TclX_Init.3 manual page for more details. The pkg_mkIndex does not generate a pkgIndex.tcl file that works with TclX. See TclX_Init.3 for instructions on how to setup a pkgIndex.tcl file for use with the package require command. There is no need to dynamically load libtkx, its only there to support wishx and applications that want wishx's signal handling. TclX will build and install a pkgIndex.tcl that will be automatically found by Tcl if TclX is installed in the same location. SUPPORT FOR EXTENDED TCL ======================== We are committed to providing continuing support for Extended Tcl. Please send questions, bug reports, and bug fixes to: http://tclx.sourceforge.net/ Use news:comp.lang.tcl for discussion about TclX development. WHERE TO GET IT =============== Extended Tcl can be downloaded from the SF TclX release files area: http://tclx.sourceforge.net/ Refer to the above site for bug database and other support forums. THANKS ====== A big thanks to all of the Extended Tcl users from all over the world who have helped us debug problems and given us valuable suggestions. A special thanks to John Ousterhout, his students at Berkeley, and (more recently) his teams at Sun Microsystems and Scriptics, for Tcl, Tk and all the support they have given us. Thanks to Michael E. Shorter , Christopher M. Sedore , Philip Chow , and Kirk Benson for their initial work on porting TclX to MS Windows. Thanks to Jan Nijtmans of Plus Patch fame for helping to get shared library support working for several system. tclx8.4-8.4.1.orig/win/0000755000000000000000000000000012046525461011357 5ustar tclx8.4-8.4.1.orig/win/tclXwinPort.h0000644000000000000000000000444612046313170014025 0ustar /* * tclXwinPort.h * * Portability include file for MS Windows systems. *----------------------------------------------------------------------------- * Copyright 1996-1999 Karl Lehenbauer and Mark Diekhans. * * Permission to use, copy, modify, and distribute this software and its * documentation for any purpose and without fee is hereby granted, provided * that the above copyright notice appear in all copies. Karl Lehenbauer and * Mark Diekhans make no representations about the suitability of this * software for any purpose. It is provided "as is" without express or * implied warranty. *----------------------------------------------------------------------------- * $Id: tclXwinPort.h,v 1.3 2005/03/24 05:11:16 hobbs Exp $ *----------------------------------------------------------------------------- */ #ifndef TCLXWINPORT_H #define TCLXWINPORT_H #include "tclWinPort.h" #include #include /* * Types needed for fstat, but are not directly supported (we emulate). If * defined before tclWinPort.h is include, it will define the access macros. */ #define S_IFIFO _S_IFIFO /* pipe */ #define S_IFSOCK 0140000 /* socket */ /* * OS feature definitons. */ #ifndef NO_CATGETS # define NO_CATGETS #endif #ifndef NO_FCHMOD # define NO_FCHMOD #endif #ifndef NO_FCHOWN # define NO_FCHOWN #endif #ifndef NO_FSYNC # define NO_FSYNC #endif #ifndef NO_RANDOM # define NO_RANDOM /* uses compat */ #endif #ifndef NO_SIGACTION # define NO_SIGACTION #endif #ifndef NO_TRUNCATE # define NO_TRUNCATE /* FIX: Are we sure there is no way to truncate???*/ #endif #ifndef RETSIGTYPE # define RETSIGTYPE void #endif #include #include #ifndef MAXDOUBLE # define MAXDOUBLE HUGE_VAL #endif /* * No restartable signals in WIN32. */ #ifndef NO_SIG_RESTART # define NO_SIG_RESTART #endif /* * Define a macro to call wait pid. We don't use Tcl_WaitPid on Unix because * it delays signals. */ #define TCLX_WAITPID(pid, status, options) \ Tcl_WaitPid((Tcl_Pid)pid, status, options) #define bcopy(from, to, length) memmove((to), (from), (length)) /* * Compaibility functions. */ extern long random(void); extern void srandom(unsigned int x); extern int getopt(int nargc, char * const *nargv, const char *ostr); #endif tclx8.4-8.4.1.orig/win/nmakehlp.c0000644000000000000000000004440412046313170013320 0ustar /* * ---------------------------------------------------------------------------- * nmakehlp.c -- * * This is used to fix limitations within nmake and the environment. * * Copyright (c) 2002 by David Gravereaux. * Copyright (c) 2006 by Pat Thoyts * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * * ---------------------------------------------------------------------------- * RCS: @(#) $Id: nmakehlp.c,v 8.1 2008/06/29 23:53:57 patthoyts Exp $ * ---------------------------------------------------------------------------- */ #define _CRT_SECURE_NO_DEPRECATE #include #define NO_SHLWAPI_GDI #define NO_SHLWAPI_STREAM #define NO_SHLWAPI_REG #include #pragma comment (lib, "user32.lib") #pragma comment (lib, "kernel32.lib") #pragma comment (lib, "shlwapi.lib") #include #include /* * This library is required for x64 builds with _some_ versions of MSVC */ #if defined(_M_IA64) || defined(_M_AMD64) #if _MSC_VER >= 1400 && _MSC_VER < 1500 #pragma comment(lib, "bufferoverflowU") #endif #endif /* ISO hack for dumb VC++ */ #ifdef _MSC_VER #define snprintf _snprintf #endif /* protos */ int CheckForCompilerFeature(const char *option); int CheckForLinkerFeature(const char *option); int IsIn(const char *string, const char *substring); int GrepForDefine(const char *file, const char *string); int SubstituteFile(const char *substs, const char *filename); int QualifyPath(const char *path); const char * GetVersionFromFile(const char *filename, const char *match); DWORD WINAPI ReadFromPipe(LPVOID args); /* globals */ #define CHUNK 25 #define STATICBUFFERSIZE 1000 typedef struct { HANDLE pipe; char buffer[STATICBUFFERSIZE]; } pipeinfo; pipeinfo Out = {INVALID_HANDLE_VALUE, '\0'}; pipeinfo Err = {INVALID_HANDLE_VALUE, '\0'}; /* * exitcodes: 0 == no, 1 == yes, 2 == error */ int main( int argc, char *argv[]) { char msg[300]; DWORD dwWritten; int chars; /* * Make sure children (cl.exe and link.exe) are kept quiet. */ SetErrorMode(SEM_FAILCRITICALERRORS | SEM_NOOPENFILEERRORBOX); /* * Make sure the compiler and linker aren't effected by the outside world. */ SetEnvironmentVariable("CL", ""); SetEnvironmentVariable("LINK", ""); if (argc > 1 && *argv[1] == '-') { switch (*(argv[1]+1)) { case 'c': if (argc != 3) { chars = snprintf(msg, sizeof(msg) - 1, "usage: %s -c \n" "Tests for whether cl.exe supports an option\n" "exitcodes: 0 == no, 1 == yes, 2 == error\n", argv[0]); WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, chars, &dwWritten, NULL); return 2; } return CheckForCompilerFeature(argv[2]); case 'l': if (argc != 3) { chars = snprintf(msg, sizeof(msg) - 1, "usage: %s -l \n" "Tests for whether link.exe supports an option\n" "exitcodes: 0 == no, 1 == yes, 2 == error\n", argv[0]); WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, chars, &dwWritten, NULL); return 2; } return CheckForLinkerFeature(argv[2]); case 'f': if (argc == 2) { chars = snprintf(msg, sizeof(msg) - 1, "usage: %s -f \n" "Find a substring within another\n" "exitcodes: 0 == no, 1 == yes, 2 == error\n", argv[0]); WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, chars, &dwWritten, NULL); return 2; } else if (argc == 3) { /* * If the string is blank, there is no match. */ return 0; } else { return IsIn(argv[2], argv[3]); } case 'g': if (argc == 2) { chars = snprintf(msg, sizeof(msg) - 1, "usage: %s -g \n" "grep for a #define\n" "exitcodes: integer of the found string (no decimals)\n", argv[0]); WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, chars, &dwWritten, NULL); return 2; } return GrepForDefine(argv[2], argv[3]); case 's': if (argc == 2) { chars = snprintf(msg, sizeof(msg) - 1, "usage: %s -s \n" "Perform a set of string map type substutitions on a file\n" "exitcodes: 0\n", argv[0]); WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, chars, &dwWritten, NULL); return 2; } return SubstituteFile(argv[2], argv[3]); case 'V': if (argc != 4) { chars = snprintf(msg, sizeof(msg) - 1, "usage: %s -V filename matchstring\n" "Extract a version from a file:\n" "eg: pkgIndex.tcl \"package ifneeded http\"", argv[0]); WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, chars, &dwWritten, NULL); return 0; } printf("%s\n", GetVersionFromFile(argv[2], argv[3])); return 0; case 'Q': if (argc != 3) { chars = snprintf(msg, sizeof(msg) - 1, "usage: %s -q path\n" "Emit the fully qualified path\n" "exitcodes: 0 == no, 1 == yes, 2 == error\n", argv[0]); WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, chars, &dwWritten, NULL); return 2; } return QualifyPath(argv[2]); } } chars = snprintf(msg, sizeof(msg) - 1, "usage: %s -c|-l|-f|-g|-V|-s|-Q ...\n" "This is a little helper app to equalize shell differences between WinNT and\n" "Win9x and get nmake.exe to accomplish its job.\n", argv[0]); WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, chars, &dwWritten, NULL); return 2; } int CheckForCompilerFeature( const char *option) { STARTUPINFO si; PROCESS_INFORMATION pi; SECURITY_ATTRIBUTES sa; DWORD threadID; char msg[300]; BOOL ok; HANDLE hProcess, h, pipeThreads[2]; char cmdline[100]; hProcess = GetCurrentProcess(); ZeroMemory(&pi, sizeof(PROCESS_INFORMATION)); ZeroMemory(&si, sizeof(STARTUPINFO)); si.cb = sizeof(STARTUPINFO); si.dwFlags = STARTF_USESTDHANDLES; si.hStdInput = INVALID_HANDLE_VALUE; ZeroMemory(&sa, sizeof(SECURITY_ATTRIBUTES)); sa.nLength = sizeof(SECURITY_ATTRIBUTES); sa.lpSecurityDescriptor = NULL; sa.bInheritHandle = FALSE; /* * Create a non-inheritible pipe. */ CreatePipe(&Out.pipe, &h, &sa, 0); /* * Dupe the write side, make it inheritible, and close the original. */ DuplicateHandle(hProcess, h, hProcess, &si.hStdOutput, 0, TRUE, DUPLICATE_SAME_ACCESS | DUPLICATE_CLOSE_SOURCE); /* * Same as above, but for the error side. */ CreatePipe(&Err.pipe, &h, &sa, 0); DuplicateHandle(hProcess, h, hProcess, &si.hStdError, 0, TRUE, DUPLICATE_SAME_ACCESS | DUPLICATE_CLOSE_SOURCE); /* * Base command line. */ lstrcpy(cmdline, "cl.exe -nologo -c -TC -Zs -X -Fp.\\_junk.pch "); /* * Append our option for testing */ lstrcat(cmdline, option); /* * Filename to compile, which exists, but is nothing and empty. */ lstrcat(cmdline, " .\\nul"); ok = CreateProcess( NULL, /* Module name. */ cmdline, /* Command line. */ NULL, /* Process handle not inheritable. */ NULL, /* Thread handle not inheritable. */ TRUE, /* yes, inherit handles. */ DETACHED_PROCESS, /* No console for you. */ NULL, /* Use parent's environment block. */ NULL, /* Use parent's starting directory. */ &si, /* Pointer to STARTUPINFO structure. */ &pi); /* Pointer to PROCESS_INFORMATION structure. */ if (!ok) { DWORD err = GetLastError(); int chars = snprintf(msg, sizeof(msg) - 1, "Tried to launch: \"%s\", but got error [%u]: ", cmdline, err); FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM|FORMAT_MESSAGE_IGNORE_INSERTS| FORMAT_MESSAGE_MAX_WIDTH_MASK, 0L, err, 0, (LPVOID)&msg[chars], (300-chars), 0); WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg,lstrlen(msg), &err,NULL); return 2; } /* * Close our references to the write handles that have now been inherited. */ CloseHandle(si.hStdOutput); CloseHandle(si.hStdError); WaitForInputIdle(pi.hProcess, 5000); CloseHandle(pi.hThread); /* * Start the pipe reader threads. */ pipeThreads[0] = CreateThread(NULL, 0, ReadFromPipe, &Out, 0, &threadID); pipeThreads[1] = CreateThread(NULL, 0, ReadFromPipe, &Err, 0, &threadID); /* * Block waiting for the process to end. */ WaitForSingleObject(pi.hProcess, INFINITE); CloseHandle(pi.hProcess); /* * Wait for our pipe to get done reading, should it be a little slow. */ WaitForMultipleObjects(2, pipeThreads, TRUE, 500); CloseHandle(pipeThreads[0]); CloseHandle(pipeThreads[1]); /* * Look for the commandline warning code in both streams. * - in MSVC 6 & 7 we get D4002, in MSVC 8 we get D9002. */ return !(strstr(Out.buffer, "D4002") != NULL || strstr(Err.buffer, "D4002") != NULL || strstr(Out.buffer, "D9002") != NULL || strstr(Err.buffer, "D9002") != NULL || strstr(Out.buffer, "D2021") != NULL || strstr(Err.buffer, "D2021") != NULL); } int CheckForLinkerFeature( const char *option) { STARTUPINFO si; PROCESS_INFORMATION pi; SECURITY_ATTRIBUTES sa; DWORD threadID; char msg[300]; BOOL ok; HANDLE hProcess, h, pipeThreads[2]; char cmdline[100]; hProcess = GetCurrentProcess(); ZeroMemory(&pi, sizeof(PROCESS_INFORMATION)); ZeroMemory(&si, sizeof(STARTUPINFO)); si.cb = sizeof(STARTUPINFO); si.dwFlags = STARTF_USESTDHANDLES; si.hStdInput = INVALID_HANDLE_VALUE; ZeroMemory(&sa, sizeof(SECURITY_ATTRIBUTES)); sa.nLength = sizeof(SECURITY_ATTRIBUTES); sa.lpSecurityDescriptor = NULL; sa.bInheritHandle = TRUE; /* * Create a non-inheritible pipe. */ CreatePipe(&Out.pipe, &h, &sa, 0); /* * Dupe the write side, make it inheritible, and close the original. */ DuplicateHandle(hProcess, h, hProcess, &si.hStdOutput, 0, TRUE, DUPLICATE_SAME_ACCESS | DUPLICATE_CLOSE_SOURCE); /* * Same as above, but for the error side. */ CreatePipe(&Err.pipe, &h, &sa, 0); DuplicateHandle(hProcess, h, hProcess, &si.hStdError, 0, TRUE, DUPLICATE_SAME_ACCESS | DUPLICATE_CLOSE_SOURCE); /* * Base command line. */ lstrcpy(cmdline, "link.exe -nologo "); /* * Append our option for testing. */ lstrcat(cmdline, option); ok = CreateProcess( NULL, /* Module name. */ cmdline, /* Command line. */ NULL, /* Process handle not inheritable. */ NULL, /* Thread handle not inheritable. */ TRUE, /* yes, inherit handles. */ DETACHED_PROCESS, /* No console for you. */ NULL, /* Use parent's environment block. */ NULL, /* Use parent's starting directory. */ &si, /* Pointer to STARTUPINFO structure. */ &pi); /* Pointer to PROCESS_INFORMATION structure. */ if (!ok) { DWORD err = GetLastError(); int chars = snprintf(msg, sizeof(msg) - 1, "Tried to launch: \"%s\", but got error [%u]: ", cmdline, err); FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM|FORMAT_MESSAGE_IGNORE_INSERTS| FORMAT_MESSAGE_MAX_WIDTH_MASK, 0L, err, 0, (LPVOID)&msg[chars], (300-chars), 0); WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg,lstrlen(msg), &err,NULL); return 2; } /* * Close our references to the write handles that have now been inherited. */ CloseHandle(si.hStdOutput); CloseHandle(si.hStdError); WaitForInputIdle(pi.hProcess, 5000); CloseHandle(pi.hThread); /* * Start the pipe reader threads. */ pipeThreads[0] = CreateThread(NULL, 0, ReadFromPipe, &Out, 0, &threadID); pipeThreads[1] = CreateThread(NULL, 0, ReadFromPipe, &Err, 0, &threadID); /* * Block waiting for the process to end. */ WaitForSingleObject(pi.hProcess, INFINITE); CloseHandle(pi.hProcess); /* * Wait for our pipe to get done reading, should it be a little slow. */ WaitForMultipleObjects(2, pipeThreads, TRUE, 500); CloseHandle(pipeThreads[0]); CloseHandle(pipeThreads[1]); /* * Look for the commandline warning code in the stderr stream. */ return !(strstr(Out.buffer, "LNK1117") != NULL || strstr(Err.buffer, "LNK1117") != NULL || strstr(Out.buffer, "LNK4044") != NULL || strstr(Err.buffer, "LNK4044") != NULL); } DWORD WINAPI ReadFromPipe( LPVOID args) { pipeinfo *pi = (pipeinfo *) args; char *lastBuf = pi->buffer; DWORD dwRead; BOOL ok; again: if (lastBuf - pi->buffer + CHUNK > STATICBUFFERSIZE) { CloseHandle(pi->pipe); return (DWORD)-1; } ok = ReadFile(pi->pipe, lastBuf, CHUNK, &dwRead, 0L); if (!ok || dwRead == 0) { CloseHandle(pi->pipe); return 0; } lastBuf += dwRead; goto again; return 0; /* makes the compiler happy */ } int IsIn( const char *string, const char *substring) { return (strstr(string, substring) != NULL); } /* * Find a specified #define by name. * * If the line is '#define TCL_VERSION "8.5"', it returns 85 as the result. */ int GrepForDefine( const char *file, const char *string) { char s1[51], s2[51], s3[51]; FILE *f = fopen(file, "rt"); if (f == NULL) { return 0; } do { int r = fscanf(f, "%50s", s1); if (r == 1 && !strcmp(s1, "#define")) { /* * Get next two words. */ r = fscanf(f, "%50s %50s", s2, s3); if (r != 2) { continue; } /* * Is the first word what we're looking for? */ if (!strcmp(s2, string)) { double d1; fclose(f); /* * Add 1 past first double quote char. "8.5" */ d1 = atof(s3 + 1); /* 8.5 */ while (floor(d1) != d1) { d1 *= 10.0; } return ((int) d1); /* 85 */ } } } while (!feof(f)); fclose(f); return 0; } /* * GetVersionFromFile -- * Looks for a match string in a file and then returns the version * following the match where a version is anything acceptable to * package provide or package ifneeded. */ const char * GetVersionFromFile( const char *filename, const char *match) { size_t cbBuffer = 100; static char szBuffer[100]; char *szResult = NULL; FILE *fp = fopen(filename, "rt"); if (fp != NULL) { /* * Read data until we see our match string. */ while (fgets(szBuffer, cbBuffer, fp) != NULL) { LPSTR p, q; p = strstr(szBuffer, match); if (p != NULL) { /* * Skip to first digit. */ while (*p && !isdigit(*p)) { ++p; } /* * Find ending whitespace. */ q = p; while (*q && (isalnum(*q) || *q == '.')) { ++q; } memcpy(szBuffer, p, q - p); szBuffer[q-p] = 0; szResult = szBuffer; break; } } fclose(fp); } return szResult; } /* * List helpers for the SubstituteFile function */ typedef struct list_item_t { struct list_item_t *nextPtr; char * key; char * value; } list_item_t; /* insert a list item into the list (list may be null) */ static list_item_t * list_insert(list_item_t **listPtrPtr, const char *key, const char *value) { list_item_t *itemPtr = malloc(sizeof(list_item_t)); if (itemPtr) { itemPtr->key = strdup(key); itemPtr->value = strdup(value); itemPtr->nextPtr = NULL; while(*listPtrPtr) { listPtrPtr = &(*listPtrPtr)->nextPtr; } *listPtrPtr = itemPtr; } return itemPtr; } static void list_free(list_item_t **listPtrPtr) { list_item_t *tmpPtr, *listPtr = *listPtrPtr; while (listPtr) { tmpPtr = listPtr; listPtr = listPtr->nextPtr; free(tmpPtr->key); free(tmpPtr->value); free(tmpPtr); } } /* * SubstituteFile -- * As windows doesn't provide anything useful like sed and it's unreliable * to use the tclsh you are building against (consider x-platform builds - * eg compiling AMD64 target from IX86) we provide a simple substitution * option here to handle autoconf style substitutions. * The substitution file is whitespace and line delimited. The file should * consist of lines matching the regular expression: * \s*\S+\s+\S*$ * * Usage is something like: * nmakehlp -S << $** > $@ * @PACKAGE_NAME@ $(PACKAGE_NAME) * @PACKAGE_VERSION@ $(PACKAGE_VERSION) * << */ int SubstituteFile( const char *substitutions, const char *filename) { size_t cbBuffer = 1024; static char szBuffer[1024], szCopy[1024]; char *szResult = NULL; list_item_t *substPtr = NULL; FILE *fp, *sp; fp = fopen(filename, "rt"); if (fp != NULL) { /* * Build a list of substutitions from the first filename */ sp = fopen(substitutions, "rt"); if (sp != NULL) { while (fgets(szBuffer, cbBuffer, sp) != NULL) { char *ks, *ke, *vs, *ve; ks = szBuffer; while (ks && *ks && isspace(*ks)) ++ks; ke = ks; while (ke && *ke && !isspace(*ke)) ++ke; vs = ke; while (vs && *vs && isspace(*vs)) ++vs; ve = vs; while (ve && *ve && !(*ve == '\r' || *ve == '\n')) ++ve; *ke = 0, *ve = 0; list_insert(&substPtr, ks, vs); } fclose(sp); } /* debug: dump the list */ #ifdef _DEBUG { int n = 0; list_item_t *p = NULL; for (p = substPtr; p != NULL; p = p->nextPtr, ++n) { fprintf(stderr, "% 3d '%s' => '%s'\n", n, p->key, p->value); } } #endif /* * Run the substitutions over each line of the input */ while (fgets(szBuffer, cbBuffer, fp) != NULL) { list_item_t *p = NULL; for (p = substPtr; p != NULL; p = p->nextPtr) { char *m = strstr(szBuffer, p->key); if (m) { char *cp, *op, *sp; cp = szCopy; op = szBuffer; while (op != m) *cp++ = *op++; sp = p->value; while (sp && *sp) *cp++ = *sp++; op += strlen(p->key); while (*op) *cp++ = *op++; *cp = 0; memcpy(szBuffer, szCopy, sizeof(szCopy)); } } printf(szBuffer); } list_free(&substPtr); } fclose(fp); return 0; } /* * QualifyPath -- * * This composes the current working directory with a provided path * and returns the fully qualified and normalized path. * Mostly needed to setup paths for testing. */ int QualifyPath( const char *szPath) { char szCwd[MAX_PATH + 1]; char szTmp[MAX_PATH + 1]; char *p; GetCurrentDirectory(MAX_PATH, szCwd); while ((p = strchr(szPath, '/')) && *p) *p = '\\'; PathCombine(szTmp, szCwd, szPath); PathCanonicalize(szCwd, szTmp); printf("%s\n", szCwd); return 0; } /* * Local variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * indent-tabs-mode: t * tab-width: 8 * End: */ tclx8.4-8.4.1.orig/win/rules.vc0000644000000000000000000003660112046313170013041 0ustar #------------------------------------------------------------------------------ # rules.vc -- # # Microsoft Visual C++ makefile include for decoding the commandline # macros. This file does not need editing to build Tcl. # # This version is modified from the Tcl source version to support # building extensions using nmake. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # Copyright (c) 2001-2002 David Gravereaux. # Copyright (c) 2003-2008 Patrick Thoyts # #------------------------------------------------------------------------------ # RCS: @(#) $Id: rules.vc,v 8.1 2008/06/29 23:53:57 patthoyts Exp $ #------------------------------------------------------------------------------ !ifndef _RULES_VC _RULES_VC = 1 cc32 = $(CC) # built-in default. link32 = link lib32 = lib rc32 = $(RC) # built-in default. !ifndef INSTALLDIR ### Assume the normal default. _INSTALLDIR = C:\Program Files\Tcl !else ### Fix the path separators. _INSTALLDIR = $(INSTALLDIR:/=\) !endif !ifndef MACHINE !if "$(CPU)" == "" || "$(CPU)" == "i386" MACHINE = IX86 !else MACHINE = $(CPU) !endif !endif !ifndef CFG_ENCODING CFG_ENCODING = \"cp1252\" !endif #---------------------------------------------------------- # Set the proper copy method to avoid overwrite questions # to the user when copying files and selecting the right # "delete all" method. #---------------------------------------------------------- !if "$(OS)" == "Windows_NT" RMDIR = rmdir /S /Q ERRNULL = 2>NUL !if ![ver | find "4.0" > nul] CPY = echo y | xcopy /i >NUL COPY = copy >NUL !else CPY = xcopy /i /y >NUL COPY = copy /y >NUL !endif !else # "$(OS)" != "Windows_NT" CPY = xcopy /i >_JUNK.OUT # On Win98 NUL does not work here. COPY = copy >_JUNK.OUT # On Win98 NUL does not work here. RMDIR = deltree /Y NULL = \NUL # Used in testing directory existence ERRNULL = >NUL # Win9x shell cannot redirect stderr !endif MKDIR = mkdir !message =============================================================================== #---------------------------------------------------------- # build the helper app we need to overcome nmake's limiting # environment. #---------------------------------------------------------- !if !exist(nmakehlp.exe) !if [$(cc32) -nologo nmakehlp.c -link -subsystem:console > nul] !endif !endif #---------------------------------------------------------- # Test for compiler features #---------------------------------------------------------- ### test for optimizations !if [nmakehlp -c -Ot] !message *** Compiler has 'Optimizations' OPTIMIZING = 1 !else !message *** Compiler does not have 'Optimizations' OPTIMIZING = 0 !endif OPTIMIZATIONS = !if [nmakehlp -c -Ot] OPTIMIZATIONS = $(OPTIMIZATIONS) -Ot !endif !if [nmakehlp -c -Oi] OPTIMIZATIONS = $(OPTIMIZATIONS) -Oi !endif !if [nmakehlp -c -Op] OPTIMIZATIONS = $(OPTIMIZATIONS) -Op !endif !if [nmakehlp -c -fp:strict] OPTIMIZATIONS = $(OPTIMIZATIONS) -fp:strict !endif !if [nmakehlp -c -Gs] OPTIMIZATIONS = $(OPTIMIZATIONS) -Gs !endif !if [nmakehlp -c -GS] OPTIMIZATIONS = $(OPTIMIZATIONS) -GS !endif !if [nmakehlp -c -GL] OPTIMIZATIONS = $(OPTIMIZATIONS) -GL !endif DEBUGFLAGS = !if [nmakehlp -c -RTC1] DEBUGFLAGS = $(DEBUGFLAGS) -RTC1 !elseif [nmakehlp -c -GZ] DEBUGFLAGS = $(DEBUGFLAGS) -GZ !endif COMPILERFLAGS =-W3 # In v13 -GL and -YX are incompatible. !if [nmakehlp -c -YX] !if ![nmakehlp -c -GL] OPTIMIZATIONS = $(OPTIMIZATIONS) -YX !endif !endif !if "$(MACHINE)" == "IX86" ### test for pentium errata !if [nmakehlp -c -QI0f] !message *** Compiler has 'Pentium 0x0f fix' COMPILERFLAGS = $(COMPILERFLAGSS) -QI0f !else !message *** Compiler does not have 'Pentium 0x0f fix' !endif !endif !if "$(MACHINE)" == "IA64" ### test for Itanium errata !if [nmakehlp -c -QIA64_Bx] !message *** Compiler has 'B-stepping errata workarounds' COMPILERFLAGS = $(COMPILERFLAGS) -QIA64_Bx !else !message *** Compiler does not have 'B-stepping errata workarounds' !endif !endif !if "$(MACHINE)" == "IX86" ### test for -align:4096, when align:512 will do. !if [nmakehlp -l -opt:nowin98] !message *** Linker has 'Win98 alignment problem' ALIGN98_HACK = 1 !else !message *** Linker does not have 'Win98 alignment problem' ALIGN98_HACK = 0 !endif !else ALIGN98_HACK = 0 !endif LINKERFLAGS = !if [nmakehlp -l -ltcg] LINKERFLAGS =-ltcg !endif #---------------------------------------------------------- # MSVC8 (ships with Visual Studio 2005) generates a manifest # file that we should link into the binaries. This is how. #---------------------------------------------------------- _VC_MANIFEST_EMBED_EXE= _VC_MANIFEST_EMBED_DLL= VCVER=0 !if ![echo VCVERSION=_MSC_VER > vercl.x] \ && ![cl -nologo -TC -P vercl.x $(ERRNULL)] !include vercl.i !if $(VCVERSION) >= 1500 VCVER=9 !elseif $(VCVERSION) >= 1400 VCVER=8 !elseif $(VCVERSION) >= 1300 VCVER=7 !elseif $(VCVERSION) >= 1200 VCVER=6 !endif !endif # Since MSVC8 we must deal with manifest resources. !if $(VCVERSION) >= 1400 _VC_MANIFEST_EMBED_EXE=if exist $@.manifest mt -nologo -manifest $@.manifest -outputresource:$@;1 _VC_MANIFEST_EMBED_DLL=if exist $@.manifest mt -nologo -manifest $@.manifest -outputresource:$@;2 !endif #---------------------------------------------------------- # Decode the options requested. #---------------------------------------------------------- !if "$(OPTS)" == "" || [nmakehlp -f "$(OPTS)" "none"] STATIC_BUILD = 0 TCL_THREADS = 1 DEBUG = 0 PROFILE = 0 MSVCRT = 0 LOIMPACT = 0 TCL_USE_STATIC_PACKAGES = 0 USE_THREAD_ALLOC = 1 USE_THREAD_STORAGE = 1 UNCHECKED = 0 !else !if [nmakehlp -f $(OPTS) "static"] !message *** Doing static STATIC_BUILD = 1 !else STATIC_BUILD = 0 !endif !if [nmakehlp -f $(OPTS) "msvcrt"] !message *** Doing msvcrt MSVCRT = 1 !else MSVCRT = 0 !endif !if [nmakehlp -f $(OPTS) "staticpkg"] !message *** Doing staticpkg TCL_USE_STATIC_PACKAGES = 1 !else TCL_USE_STATIC_PACKAGES = 0 !endif !if [nmakehlp -f $(OPTS) "nothreads"] !message *** Compile explicitly for non-threaded tcl TCL_THREADS = 0 !else TCL_THREADS = 1 !endif !if [nmakehlp -f $(OPTS) "symbols"] !message *** Doing symbols DEBUG = 1 !else DEBUG = 0 !endif !if [nmakehlp -f $(OPTS) "profile"] !message *** Doing profile PROFILE = 1 !else PROFILE = 0 !endif !if [nmakehlp -f $(OPTS) "loimpact"] !message *** Doing loimpact LOIMPACT = 1 !else LOIMPACT = 0 !endif !if [nmakehlp -f $(OPTS) "thrdalloc"] !message *** Doing thrdalloc USE_THREAD_ALLOC = 1 !else USE_THREAD_ALLOC = 0 !endif !if [nmakehlp -f $(OPTS) "thrdstorage"] !message *** Doing thrdstorage USE_THREAD_STORAGE = 1 !else USE_THREAD_STORAGE = 0 !endif !if [nmakehlp -f $(OPTS) "unchecked"] !message *** Doing unchecked UNCHECKED = 1 !else UNCHECKED = 0 !endif !endif !if !$(STATIC_BUILD) # Make sure we don't build overly fat DLLs. MSVCRT = 1 # We shouldn't statically put the extensions inside the shell when dynamic. TCL_USE_STATIC_PACKAGES = 0 !endif #---------------------------------------------------------- # Figure-out how to name our intermediate and output directories. # We wouldn't want different builds to use the same .obj files # by accident. #---------------------------------------------------------- #---------------------------------------- # Naming convention: # t = full thread support. # s = static library (as opposed to an # import library) # g = linked to the debug enabled C # run-time. # x = special static build when it # links to the dynamic C run-time. #---------------------------------------- SUFX = sgx !if $(DEBUG) BUILDDIRTOP = Debug !else BUILDDIRTOP = Release !endif !if "$(MACHINE)" != "IX86" BUILDDIRTOP =$(BUILDDIRTOP)_$(MACHINE) !endif !if $(VCVER) > 6 BUILDDIRTOP =$(BUILDDIRTOP)_VC$(VCVER) !endif !if !$(DEBUG) || $(DEBUG) && $(UNCHECKED) SUFX = $(SUFX:g=) !endif TMP_DIRFULL = .\$(BUILDDIRTOP)\$(PROJECT)_ThreadedDynamicStaticX !if !$(STATIC_BUILD) TMP_DIRFULL = $(TMP_DIRFULL:Static=) SUFX = $(SUFX:s=) EXT = dll !if $(MSVCRT) TMP_DIRFULL = $(TMP_DIRFULL:X=) SUFX = $(SUFX:x=) !endif !else TMP_DIRFULL = $(TMP_DIRFULL:Dynamic=) EXT = lib !if !$(MSVCRT) TMP_DIRFULL = $(TMP_DIRFULL:X=) SUFX = $(SUFX:x=) !endif !endif !if !$(TCL_THREADS) TMP_DIRFULL = $(TMP_DIRFULL:Threaded=) SUFX = $(SUFX:t=) !endif !ifndef TMP_DIR TMP_DIR = $(TMP_DIRFULL) !ifndef OUT_DIR OUT_DIR = .\$(BUILDDIRTOP) !endif !else !ifndef OUT_DIR OUT_DIR = $(TMP_DIR) !endif !endif #---------------------------------------------------------- # Decode the statistics requested. #---------------------------------------------------------- !if "$(STATS)" == "" || [nmakehlp -f "$(STATS)" "none"] TCL_MEM_DEBUG = 0 TCL_COMPILE_DEBUG = 0 !else !if [nmakehlp -f $(STATS) "memdbg"] !message *** Doing memdbg TCL_MEM_DEBUG = 1 !else TCL_MEM_DEBUG = 0 !endif !if [nmakehlp -f $(STATS) "compdbg"] !message *** Doing compdbg TCL_COMPILE_DEBUG = 1 !else TCL_COMPILE_DEBUG = 0 !endif !endif #---------------------------------------------------------- # Decode the checks requested. #---------------------------------------------------------- !if "$(CHECKS)" == "" || [nmakehlp -f "$(CHECKS)" "none"] TCL_NO_DEPRECATED = 0 WARNINGS = -W3 !else !if [nmakehlp -f $(CHECKS) "nodep"] !message *** Doing nodep check TCL_NO_DEPRECATED = 1 !else TCL_NO_DEPRECATED = 0 !endif !if [nmakehlp -f $(CHECKS) "fullwarn"] !message *** Doing full warnings check WARNINGS = -W4 !if [nmakehlp -l -warn:3] LINKERFLAGS = $(LINKERFLAGS) -warn:3 !endif !else WARNINGS = -W3 !endif !if [nmakehlp -f $(CHECKS) "64bit"] && [nmakehlp -c -Wp64] !message *** Doing 64bit portability warnings WARNINGS = $(WARNINGS) -Wp64 !endif !endif #---------------------------------------------------------- # Set our defines now armed with our options. #---------------------------------------------------------- OPTDEFINES = -DTCL_CFGVAL_ENCODING=$(CFG_ENCODING) -DSTDC_HEADERS !if $(TCL_MEM_DEBUG) OPTDEFINES = $(OPTDEFINES) -DTCL_MEM_DEBUG !endif !if $(TCL_COMPILE_DEBUG) OPTDEFINES = $(OPTDEFINES) -DTCL_COMPILE_DEBUG -DTCL_COMPILE_STATS !endif !if $(TCL_THREADS) OPTDEFINES = $(OPTDEFINES) -DTCL_THREADS=1 !if $(USE_THREAD_ALLOC) OPTDEFINES = $(OPTDEFINES) -DUSE_THREAD_ALLOC=1 !endif !if $(USE_THREAD_STORAGE) OPTDEFINES = $(OPTDEFINES) -DUSE_THREAD_STORAGE=1 !endif !endif !if $(STATIC_BUILD) OPTDEFINES = $(OPTDEFINES) -DSTATIC_BUILD !endif !if $(TCL_NO_DEPRECATED) OPTDEFINES = $(OPTDEFINES) -DTCL_NO_DEPRECATED !endif !if $(DEBUG) OPTDEFINES = $(OPTDEFINES) -DTCL_CFG_DEBUG !elseif $(OPTIMIZING) OPTDEFINES = $(OPTDEFINES) -DTCL_CFG_OPTIMIZED !endif !if $(PROFILE) OPTDEFINES = $(OPTDEFINES) -DTCL_CFG_PROFILED !endif !if "$(MACHINE)" == "IA64" || "$(MACHINE)" == "AMD64" OPTDEFINES = $(OPTDEFINES) -DTCL_CFG_DO64BIT !endif #---------------------------------------------------------- # Get common info used when building extensions. #---------------------------------------------------------- !if "$(PROJECT)" != "tcl" # If INSTALLDIR set to tcl root dir then reset to the lib dir. !if exist("$(_INSTALLDIR)\include\tcl.h") _INSTALLDIR=$(_INSTALLDIR)\lib !endif !if !defined(TCLDIR) !if exist("$(_INSTALLDIR)\..\include\tcl.h") TCLINSTALL = 1 _TCLDIR = $(_INSTALLDIR)\.. _TCL_H = $(_INSTALLDIR)\..\include\tcl.h TCLDIR = $(_INSTALLDIR)\.. !else MSG=^ Failed to find tcl.h. Set the TCLDIR macro. !error $(MSG) !endif !else _TCLDIR = $(TCLDIR:/=\) !if exist("$(_TCLDIR)\include\tcl.h") TCLINSTALL = 1 _TCL_H = $(_TCLDIR)\include\tcl.h !elseif exist("$(_TCLDIR)\generic\tcl.h") TCLINSTALL = 0 _TCL_H = $(_TCLDIR)\generic\tcl.h !else MSG =^ Failed to find tcl.h. The TCLDIR macro does not appear correct. !error $(MSG) !endif !endif !if [echo REM = This file is generated from rules.vc > version.vc] !endif !if exist("$(_TCL_H)") !if [echo TCL_DOTVERSION = \>> version.vc] \ && [nmakehlp -V "$(_TCL_H)" TCL_VERSION >> version.vc] !endif !endif !include version.vc TCL_VERSION = $(TCL_DOTVERSION:.=) !if $(TCLINSTALL) TCLSH = "$(_TCLDIR)\bin\tclsh$(TCL_VERSION)$(SUFX).exe" !if !exist($(TCLSH)) && $(TCL_THREADS) TCLSH = "$(_TCLDIR)\bin\tclsh$(TCL_VERSION)t$(SUFX).exe" !endif TCLSTUBLIB = "$(_TCLDIR)\lib\tclstub$(TCL_VERSION).lib" TCLIMPLIB = "$(_TCLDIR)\lib\tcl$(TCL_VERSION)$(SUFX).lib" TCL_LIBRARY = $(_TCLDIR)\lib TCL_INCLUDES = -I"$(_TCLDIR)\include" !else TCLSH = "$(_TCLDIR)\win\$(BUILDDIRTOP)\tclsh$(TCL_VERSION)$(SUFX).exe" !if !exist($(TCLSH)) && $(TCL_THREADS) TCLSH = "$(_TCLDIR)\win\$(BUILDDIRTOP)\tclsh$(TCL_VERSION)t$(SUFX).exe" !endif TCLSTUBLIB = "$(_TCLDIR)\win\$(BUILDDIRTOP)\tclstub$(TCL_VERSION).lib" TCLIMPLIB = "$(_TCLDIR)\win\$(BUILDDIRTOP)\tcl$(TCL_VERSION)$(SUFX).lib" TCL_LIBRARY = $(_TCLDIR)\library TCL_INCLUDES = -I"$(_TCLDIR)\generic" -I"$(_TCLDIR)\win" !endif !endif #---------------------------------------------------------- # Optionally check for Tk info for building extensions. #---------------------------------------------------------- !ifdef PROJECT_REQUIRES_TK !if "$(PROJECT)" != "tcl" && "$(PROJECT)" != "tk" !if !defined(TKDIR) !if exist("$(_INSTALLDIR)\..\include\tk.h") TKINSTALL = 1 _TKDIR = $(_INSTALLDIR)\.. _TK_H = $(_TKDIR)\include\tk.h TKDIR = $(_TKDIR) !elseif exist("$(_TCLDIR)\include\tk.h") TKINSTALL = 1 _TKDIR = $(_TCLDIR) _TK_H = $(_TKDIR)\include\tk.h TKDIR = $(_TKDIR) !endif !else _TKDIR = $(TKDIR:/=\) !if exist("$(_TKDIR)\include\tk.h") TKINSTALL = 1 _TK_H = $(_TKDIR)\include\tk.h !elseif exist("$(_TKDIR)\generic\tk.h") TKINSTALL = 0 _TK_H = $(_TKDIR)\generic\tk.h !else MSG =^ Failed to find tk.h. The TKDIR macro does not appear correct. !error $(MSG) !endif !endif !if defined(TKDIR) TK_DOTVERSION = 8.4 !if exist("$(_TK_H)") !if [echo TK_DOTVERSION = \>> version.vc] \ && [nmakehlp -V "$(_TK_H)" TK_VERSION >> version.vc] !endif !endif !include version.vc TK_VERSION = $(TK_DOTVERSION:.=) !if $(TKINSTALL) WISH = "$(_TKDIR)\bin\wish$(TK_VERSION)$(SUFX).exe" !if !exist($(WISH)) && $(TCL_THREADS) WISH = "$(_TKDIR)\bin\wish$(TK_VERSION)t$(SUFX).exe" !endif TKSTUBLIB = "$(_TKDIR)\lib\tkstub$(TK_VERSION).lib" TKIMPLIB = "$(_TKDIR)\lib\tk$(TK_VERSION)$(SUFX).lib" TK_INCLUDES = -I"$(_TKDIR)\include" TK_LIBRARY = $(_TKDIR)\lib !else WISH = "$(_TKDIR)\win\$(BUILDDIRTOP)\wish$(TCL_VERSION)$(SUFX).exe" !if !exist($(WISH)) && $(TCL_THREADS) WISH = "$(_TKDIR)\win\$(BUILDDIRTOP)\wish$(TCL_VERSION)t$(SUFX).exe" !endif TKSTUBLIB = "$(_TKDIR)\win\$(BUILDDIRTOP)\tkstub$(TCL_VERSION).lib" TKIMPLIB = "$(_TKDIR)\win\$(BUILDDIRTOP)\tk$(TCL_VERSION)$(SUFX).lib" TK_INCLUDES = -I"$(_TKDIR)\generic" -I"$(_TKDIR)\win" -I"$(_TKDIR)\xlib" TK_LIBRARY = $(_TKDIR)\library !endif !endif !endif !endif #---------------------------------------------------------- # Setup the fully qualified OUT_DIR path as OUT_DIR_PATH #---------------------------------------------------------- !if [echo OUT_DIR_PATH = \>> version.vc] \ && [nmakehlp -Q "$(OUT_DIR)" >> version.vc] !endif !include version.vc #---------------------------------------------------------- # Display stats being used. #---------------------------------------------------------- !message *** Intermediate directory will be '$(TMP_DIR)' !message *** Output directory will be '$(OUT_DIR)' !message *** Suffix for binaries will be '$(SUFX)' !message *** Optional defines are '$(OPTDEFINES)' !message *** Compiler version $(VCVER). Target machine is $(MACHINE) !message *** Compiler options '$(COMPILERFLAGS) $(OPTIMIZATIONS) $(DEBUGFLAGS) $(WARNINGS)' !message *** Link options '$(LINKERFLAGS)' !endif tclx8.4-8.4.1.orig/win/tclXwinDup.c0000644000000000000000000001743212046313170013623 0ustar /* * tclXwinDup.c * * Support for the dup command on Windows. *----------------------------------------------------------------------------- * Copyright 1991-1999 Karl Lehenbauer and Mark Diekhans. * * Permission to use, copy, modify, and distribute this software and its * documentation for any purpose and without fee is hereby granted, provided * that the above copyright notice appear in all copies. Karl Lehenbauer and * Mark Diekhans make no representations about the suitability of this * software for any purpose. It is provided "as is" without express or * implied warranty. *----------------------------------------------------------------------------- * $Id: tclXwinDup.c,v 1.1 2001/10/24 23:31:50 hobbs Exp $ *----------------------------------------------------------------------------- */ #include "tclExtdInt.h" /*----------------------------------------------------------------------------- * ConvertChannelName -- * * Convert a requested channel name to one of the standard channel ids. * * Parameters: * o interp - Errors are returned in result. * o channelName - Desired channel, one of "stdin", "stdout" or "stderr". * o handleIdPtr - One of STD_{INPUT|OUTPUT|ERROR}_HANDLE is returned. * Returns: * TCL_OK or TCL_ERROR. * FIX: Make Unix version parallel this one. *----------------------------------------------------------------------------- */ static int ConvertChannelName (Tcl_Interp *interp, char *channelName, DWORD *handleIdPtr) { if (channelName [0] == 's') { if (STREQU (channelName, "stdin")) *handleIdPtr = STD_INPUT_HANDLE; else if (STREQU (channelName, "stdout")) *handleIdPtr = STD_OUTPUT_HANDLE; else if (STREQU (channelName, "stderr")) *handleIdPtr = STD_ERROR_HANDLE; } else if (STRNEQU (channelName, "file", 4) || STRNEQU (channelName, "sock", 4)) { TclX_AppendObjResult (interp, "on MS Windows, only stdin, ", "stdout or stderr maybe the dup target", (char *) NULL); return TCL_ERROR; } else { TclX_AppendObjResult (interp, "invalid channel id: ", channelName, (char *) NULL); return TCL_ERROR; } return TCL_OK; } /*----------------------------------------------------------------------------- * TclXOSDupChannel -- * OS dependent duplication of a channel. * * Parameters: * o interp (I) - If an error occures, the error message is in result. * o srcChannel (I) - The channel to dup. * o mode (I) - The channel mode. * o targetChannelId (I) - The id for the new file. NULL if any id maybe * used. * Returns: * The unregistered new channel, or NULL if an error occured. *----------------------------------------------------------------------------- */ Tcl_Channel TclXOSDupChannel (interp, srcChannel, mode, targetChannelId) Tcl_Interp *interp; Tcl_Channel srcChannel; int mode; char *targetChannelId; { Tcl_Channel newChannel = NULL; int direction; int result; HANDLE srcFileHand, newFileHand = INVALID_HANDLE_VALUE; int sockType; int sockTypeLen = sizeof(sockType); /* * On Windows, the channels we can dup share the same file for the read and * write directions, so use either. */ if (mode & TCL_READABLE) { direction = TCL_READABLE; } else { direction = TCL_WRITABLE; } result = (Tcl_GetChannelHandle (srcChannel, direction, (ClientData *) &srcFileHand)); if (result != TCL_OK) { TclX_AppendObjResult (interp, "channel \"", Tcl_GetChannelName (srcChannel), "\" has no device handle", (char *) NULL); return NULL; } switch (GetFileType (srcFileHand)) { case FILE_TYPE_PIPE: if (getsockopt((SOCKET)srcFileHand, SOL_SOCKET, SO_TYPE, (void *)&sockType, &sockTypeLen) == 0) { TclXNotAvailableError (interp, "duping a socket"); return NULL; } break; default: break; } /* * Duplicate the channel's file. */ if (!DuplicateHandle (GetCurrentProcess (), srcFileHand, GetCurrentProcess (), &newFileHand, 0, FALSE, DUPLICATE_SAME_ACCESS)) { TclWinConvertError (GetLastError ()); TclX_AppendObjResult (interp, "dup failed: ", Tcl_PosixError (interp), (char *) NULL); goto errorExit; } /* * If a standard target channel is specified, close the target if its open * and make the new channel one of the std channels. */ if (targetChannelId != NULL) { Tcl_Channel oldChannel; DWORD stdHandleId; if (ConvertChannelName (interp, targetChannelId, &stdHandleId) != TCL_OK) goto errorExit; oldChannel = Tcl_GetChannel (interp, targetChannelId, NULL); if (oldChannel != NULL) { Tcl_UnregisterChannel (interp, oldChannel); } SetStdHandle (stdHandleId, newFileHand); } newChannel = Tcl_MakeFileChannel ((ClientData) newFileHand, mode); return newChannel; errorExit: if (newFileHand != INVALID_HANDLE_VALUE) CloseHandle (newFileHand); return NULL; } /*----------------------------------------------------------------------------- * TclXOSBindOpenFile -- * Bind a open file number of a channel. * * Parameters: * o interp (I) - If an error occures, the error message is in result. * o fileNum (I) - The file number of the open file. * Returns: * The unregistered channel or NULL if an error occurs. *----------------------------------------------------------------------------- */ Tcl_Channel TclXOSBindOpenFile (interp, fileNum) Tcl_Interp *interp; int fileNum; { HANDLE fileHandle; int mode, isSocket; char channelName[20]; char fileNumStr[20]; Tcl_Channel channel = NULL; int sockType; int sockTypeLen = sizeof(sockType); /* * Make sure file is open and determine the access mode and file type. * Currently, we just make sure it's open, and assume both read and write. * FIX: find an API under Windows that returns the read/write info. */ fileHandle = (HANDLE) fileNum; switch (GetFileType (fileHandle)) { case FILE_TYPE_UNKNOWN: TclWinConvertError (GetLastError ()); goto posixError; case FILE_TYPE_PIPE: isSocket = getsockopt((SOCKET)fileHandle, SOL_SOCKET, SO_TYPE, (void *)&sockType, &sockTypeLen) == 0; break; default: isSocket = 0; break; } mode = TCL_READABLE | TCL_WRITABLE; sprintf (fileNumStr, "%d", fileNum); if (isSocket) sprintf (channelName, "sock%s", fileNumStr); else sprintf (channelName, "file%s", fileNumStr); if (Tcl_GetChannel (interp, channelName, NULL) != NULL) { Tcl_ResetResult (interp); TclX_AppendObjResult (interp, "file number \"", fileNumStr, "\" is already bound to a Tcl channel", (char *) NULL); return NULL; } Tcl_ResetResult (interp); if (isSocket) { channel = Tcl_MakeTcpClientChannel ((ClientData) fileNum); } else { channel = Tcl_MakeFileChannel ((ClientData) fileNum, mode); } Tcl_RegisterChannel (interp, channel); return channel; posixError: TclX_AppendObjResult (interp, "binding open file ", fileNumStr, " to Tcl channel failed: ", Tcl_PosixError (interp), (char *) NULL); if (channel != NULL) { Tcl_UnregisterChannel (interp, channel); } return NULL; } tclx8.4-8.4.1.orig/win/INSTALL.txt0000644000000000000000000000622712046313170013225 0ustar Building TclX on Windows 95/NT This has not been updated for TclX 8.4. The Win32 port of TclX is a work in progress, and is not yet complete. Several features that should work under Windows are not yet ported. Many of the tests have not yet been converted to work under Windows, either. TclX on Windows is available in the ActiveTcl binary distribution: http://www.activestate.com/Tcl To build the release: o You need Visual C++ 4.0 or above. o Tcl 8.4 should be in a directory adjacent to the tclX8.4 directory or the paths in common.vc need to be changed. MICROSOFT VISUAL C++ BUILD o Edit tclX8.4/win/common.vc to set the macro TOOLS32 to the path to the install directory for MS Visual C++ 4.o. By default, this is c:\msdev. o Edit tclX8.4/win/common.vc to set the macro PREFIX to the location you want TclX installed. This PREFIX's parent directory must exist, all other directories, including PREFIX will be built if they don't exist. The resulting directories that will be used for installation are: $(PREFIX)/bin - Executables and DLLs. $(PREFIX)/lib/tclX8.4 - Runtime Tcl code and help files for TclX. $(PREFIX)/include - Include files. o To compile, cd to tclX8.4/win and enter the command: nmake -f makefile.vc o To run the TclX tests: nmake -f makefile.vc test o To install: nmake -f makefile.vc install o If you want to debug under MS Developer Studio, its easy to wrap a workspace around the existing makefile.vc: o Select File->Open o In the Open dialog: o Set the "Files of Type" field to be "All Files (*.*)" o Set the "Open As" field to be "Makefile" o Now select "tclX8.4/tcl/win/makefile.vc" using the standard open dialog. o A warning dialog will come up asking if you want to wrap a workspace around the makefile. Answer "Yes'. o A Save As dialog will appear with the "File name" field default to "makefile1.mak". Change this to be "tclx.mak". o Press "Save". o You can now use File->Open Workspace to open "tclx.mdp". In this release, the following restrictions apply: o Support is only provided for Borland C++ 5.01 and above. o The following commands are not supported: o fork o The following commands are not yet implemented: o chmod o chown o chgrp o link o nice o alarm o The following commands are there, but not tested, since the tests have not been ported. o signal o flock o The select command only works on sockets. o The id command is limited, only the host and process options are implemented o The dup command does not work on sockets. o The profile command only reports elasped real time, CPU time is not available. o There are probably problems with using open sockets and pipes with commands that operate on open files. o No 16 bit support. o The fork command is not implemented, but the execl command creates a process and returns its process id. tclx8.4-8.4.1.orig/win/tclXwinId.c0000644000000000000000000001005712046313170013423 0ustar /* * tclXwinId.c -- * * Win32 version of the id command. *----------------------------------------------------------------------------- * Copyright 1991-1999 Karl Lehenbauer and Mark Diekhans. * * Permission to use, copy, modify, and distribute this software and its * documentation for any purpose and without fee is hereby granted, provided * that the above copyright notice appear in all copies. Karl Lehenbauer and * Mark Diekhans make no representations about the suitability of this * software for any purpose. It is provided "as is" without express or * implied warranty. *----------------------------------------------------------------------------- * $Id: tclXwinId.c,v 1.1 2001/10/24 23:31:50 hobbs Exp $ *----------------------------------------------------------------------------- */ #include "tclExtdInt.h" /* * Prototypes of internal functions. */ static int IdProcess _ANSI_ARGS_((Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int IdHost _ANSI_ARGS_((Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int TclX_IdObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); /*----------------------------------------------------------------------------- * Tcl_IdCmd -- * Implements the TclX id command on Win32. * * id host * id process * * Results: * Standard TCL results, may return the Posix system error message. * *----------------------------------------------------------------------------- */ /* * id process */ static int IdProcess (interp, objc, objv) Tcl_Interp *interp; int objc; Tcl_Obj *CONST objv[]; { Tcl_Obj *resultPtr = Tcl_GetObjResult (interp); if (objc != 2) { TclX_AppendObjResult (interp, tclXWrongArgs, objv [0], " process", (char *) NULL); return TCL_ERROR; } Tcl_SetLongObj (resultPtr, getpid()); return TCL_OK; } /* * id host */ static int IdHost (interp, objc, objv) Tcl_Interp *interp; int objc; Tcl_Obj *CONST objv[]; { char hostName [TCL_RESULT_SIZE]; if (objc != 2) { TclX_AppendObjResult (interp, tclXWrongArgs, objv [0], " host", (char *) NULL); return TCL_ERROR; } if (gethostname (hostName, sizeof (hostName)) < 0) { TclX_AppendObjResult (interp, "failed to get host name: ", Tcl_PosixError (interp), (char *) NULL); return TCL_ERROR; } TclX_AppendObjResult (interp, hostName, (char *) NULL); return TCL_OK; } static int TclX_IdObjCmd (clientData, interp, objc, objv) ClientData clientData; Tcl_Interp *interp; int objc; Tcl_Obj *CONST objv[]; { char *optionPtr; if (objc < 2) { TclX_AppendObjResult (interp, tclXWrongArgs, objv [0], " arg ?arg...?", (char *) NULL); return TCL_ERROR; } optionPtr = Tcl_GetStringFromObj (objv[1], NULL); /* * If the first argument is "process", return the process ID, parent's * process ID, process group or set the process group depending on args. */ if (STREQU (optionPtr, "process")) { return IdProcess (interp, objc, objv); } /* * Handle returning the host name if its available. */ if (STREQU (optionPtr, "host")) { return IdHost (interp, objc, objv); } TclX_AppendObjResult (interp, "second arg must be one of \"process\", ", "or \"host\"", (char *) NULL); return TCL_ERROR; } /*----------------------------------------------------------------------------- * TclX_IdInit -- * Initialize the id command. *----------------------------------------------------------------------------- */ void TclX_IdInit (interp) Tcl_Interp *interp; { Tcl_CreateObjCommand (interp, "id", TclX_IdObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc*) NULL); } tclx8.4-8.4.1.orig/win/tclXwinCmds.c0000644000000000000000000000626112046313170013757 0ustar /* * tclXwinCmds.c -- * * Tcl commands to access Win32 functionality and stubs for Unix commands that * are not implemented. *----------------------------------------------------------------------------- * Copyright 1991-1999 Karl Lehenbauer and Mark Diekhans. * * Permission to use, copy, modify, and distribute this software and its * documentation for any purpose and without fee is hereby granted, provided * that the above copyright notice appear in all copies. Karl Lehenbauer and * Mark Diekhans make no representations about the suitability of this * software for any purpose. It is provided "as is" without express or * implied warranty. *----------------------------------------------------------------------------- * $Id: tclXwinCmds.c,v 1.2 2002/04/04 06:13:02 hobbs Exp $ *----------------------------------------------------------------------------- */ #include "tclExtdInt.h" static int TclX_ChrootObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int TclX_TimesObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); /*----------------------------------------------------------------------------- * Tcl_ChrootObjCmd -- * Stub to return an error if the chroot command is used on Windows. *----------------------------------------------------------------------------- */ static int TclX_ChrootObjCmd (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { return TclXNotAvailableObjError (interp, objv [0]); } /*----------------------------------------------------------------------------- * Tcl_TimesObjCmd -- * Stub to return an error if the times command is used on Windows. *----------------------------------------------------------------------------- */ static int TclX_TimesObjCmd (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { return TclXNotAvailableObjError (interp, objv [0]); } /*----------------------------------------------------------------------------- * TclX_PlatformCmdsInit -- * Initialize the platform-specific commands. *----------------------------------------------------------------------------- */ void TclX_PlatformCmdsInit (interp) Tcl_Interp *interp; { Tcl_CreateObjCommand (interp, "chroot", TclX_ChrootObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateObjCommand (interp, "times", TclX_TimesObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc*) NULL); } /*----------------------------------------------------------------------------- * TclX_ServerInit -- * * Stub, does nothing. The Unix version of the function initilizes some * compatiblity functions that are not implemented on Win32. *----------------------------------------------------------------------------- */ void TclX_ServerInit (Tcl_Interp *interp) { } tclx8.4-8.4.1.orig/win/pkgIndex.tcl.in0000644000000000000000000000031712046313170014232 0ustar # Package index for TclX @TCLX_FULL_VERSION@. # if {![package vsatisfies [package provide Tcl] 8.4]} { return } package ifneeded Tclx @PACKAGE_VERSION@ \ [list load [file join $dir @PKG_LIB_FILE@] Tclx] tclx8.4-8.4.1.orig/win/makefile.vc0000644000000000000000000004014612046313170013463 0ustar # makefile.vc -- -*- Makefile -*- # # Microsoft Visual C++ makefile for use with nmake.exe v1.62+ (VC++ 5.0+) # # This makefile is based upon the Tcl 8.4 Makefile.vc and modified to # make it suitable as a general package makefile. Look for the word EDIT # which marks sections that may need modification. As a minumum you will # need to change the PROJECT, DOTVERSION and DLLOBJS variables to values # relevant to your package. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # Copyright (c) 1995-1996 Sun Microsystems, Inc. # Copyright (c) 1998-2000 Ajuba Solutions. # Copyright (c) 2001 ActiveState Corporation. # Copyright (c) 2001-2002 David Gravereaux. # Copyright (c) 2003-2006 Pat Thoyts # #------------------------------------------------------------------------- # RCS: @(#)$Id: makefile.vc,v 8.6 2008/06/29 23:53:57 patthoyts Exp $ #------------------------------------------------------------------------- # Check to see we are configured to build with MSVC (MSDEVDIR or MSVCDIR) # or with the MS Platform SDK (MSSDK). Visual Studio .NET 2003 and 2005 define # VCINSTALLDIR instead. The MSVC Toolkit release defines yet another. !if !defined(MSDEVDIR) && !defined(MSVCDIR) && !defined(MSSDK) && !defined(VCINSTALLDIR) && !defined(VCToolkitInstallDir) MSG = ^ You need to run vcvars32.bat from Developer Studio or setenv.bat from the^ Platform SDK first to setup the environment. Jump to this line to read^ the build instructions. !error $(MSG) !endif #------------------------------------------------------------------------------ # HOW TO USE this makefile: # # 1) It is now necessary to have %MSVCDir% set in the environment. This is # used as a check to see if vcvars32.bat had been run prior to running # nmake or during the installation of Microsoft Visual C++, MSVCDir had # been set globally and the PATH adjusted. Either way is valid. # # You'll need to run vcvars32.bat contained in the MsDev's vc(98)/bin # directory to setup the proper environment, if needed, for your current # setup. This is a needed bootstrap requirement and allows the swapping of # different environments to be easier. # # 2) To use the Platform SDK (not expressly needed), run setenv.bat after # vcvars32.bat according to the instructions for it. This can also turn on # the 64-bit compiler, if your SDK has it. # # 3) Targets are: # all -- Builds everything. # -- Builds the project (eg: nmake sample) # test -- Builds and runs the test suite. # install -- Installs the built binaries and libraries to $(INSTALLDIR) # in an appropriate subdirectory. # clean/realclean/distclean -- varying levels of cleaning. # # 4) Macros usable on the commandline: # INSTALLDIR= # Sets where to install Tcl from the built binaries. # C:\Progra~1\Tcl is assumed when not specified. # # OPTS=static,msvcrt,staticpkg,threads,symbols,profile,loimpact,none # Sets special options for the core. The default is for none. # Any combination of the above may be used (comma separated). # 'none' will over-ride everything to nothing. # # static = Builds a static library of the core instead of a # dll. The shell will be static (and large), as well. # msvcrt = Effects the static option only to switch it from # using libcmt(d) as the C runtime [by default] to # msvcrt(d). This is useful for static embedding # support. # staticpkg = Effects the static option only to switch # tclshXX.exe to have the dde and reg extension linked # inside it. # nothreads = Turns off multithreading support (not recommended) # thrdalloc = Use the thread allocator (shared global free pool). # symbols = Adds symbols for step debugging. # profile = Adds profiling hooks. Map file is assumed. # loimpact = Adds a flag for how NT treats the heap to keep memory # in use, low. This is said to impact alloc performance. # # STATS=memdbg,compdbg,none # Sets optional memory and bytecode compiler debugging code added # to the core. The default is for none. Any combination of the # above may be used (comma separated). 'none' will over-ride # everything to nothing. # # memdbg = Enables the debugging memory allocator. # compdbg = Enables byte compilation logging. # # MACHINE=(IX86|IA64|ALPHA|AMD64) # Set the machine type used for the compiler, linker, and # resource compiler. This hook is needed to tell the tools # when alternate platforms are requested. IX86 is the default # when not specified. If the CPU environment variable has been # set (ie: recent Platform SDK) then MACHINE is set from CPU. # # TMP_DIR= # OUT_DIR= # Hooks to allow the intermediate and output directories to be # changed. $(OUT_DIR) is assumed to be # $(BINROOT)\(Release|Debug) based on if symbols are requested. # $(TMP_DIR) will de $(OUT_DIR)\ by default. # # TESTPAT= # Reads the tests requested to be run from this file. # # CFG_ENCODING=encoding # name of encoding for configuration information. Defaults # to cp1252 # # 5) Examples: # # Basic syntax of calling nmake looks like this: # nmake [-nologo] -f makefile.vc [target|macrodef [target|macrodef] [...]] # # Standard (no frills) # c:\tcl_src\win\>c:\progra~1\micros~1\vc98\bin\vcvars32.bat # Setting environment for using Microsoft Visual C++ tools. # c:\tcl_src\win\>nmake -f makefile.vc all # c:\tcl_src\win\>nmake -f makefile.vc install INSTALLDIR=c:\progra~1\tcl # # Building for Win64 # c:\tcl_src\win\>c:\progra~1\micros~1\vc98\bin\vcvars32.bat # Setting environment for using Microsoft Visual C++ tools. # c:\tcl_src\win\>c:\progra~1\platfo~1\setenv.bat /pre64 /RETAIL # Targeting Windows pre64 RETAIL # c:\tcl_src\win\>nmake -f makefile.vc MACHINE=IA64 # #------------------------------------------------------------------------------ #============================================================================== ############################################################################### #------------------------------------------------------------------------------ !if !exist("makefile.vc") MSG = ^ You must run this makefile only from the directory it is in.^ Please `cd` to its location first. !error $(MSG) !endif #------------------------------------------------------------------------- # Project specific information (EDIT) # # You should edit this with the name and version of your project. This # information is used to generate the name of the package library and # it's install location. # # For example, the sample extension is going to build sample04.dll and # would install it into $(INSTALLDIR)\lib\sample04 # # You need to specify the object files that need to be linked into your # binary here. # #------------------------------------------------------------------------- PROJECT = tclx # Uncomment the following line if this is a Tk extension. #PROJECT_REQUIRES_TK=1 !include "rules.vc" FULL_VERSION = 8.4.0 DOTVERSION = 8.4 VERSION = $(DOTVERSION:.=) STUBPREFIX = $(PROJECT)stub DLLOBJS = \ $(TMP_DIR)\tclXbsearch.obj \ $(TMP_DIR)\tclXchmod.obj \ $(TMP_DIR)\tclXcmdloop.obj \ $(TMP_DIR)\tclXdebug.obj \ $(TMP_DIR)\tclXdup.obj \ $(TMP_DIR)\tclXfcntl.obj \ $(TMP_DIR)\tclXfilecmds.obj \ $(TMP_DIR)\tclXfilescan.obj \ $(TMP_DIR)\tclXflock.obj \ $(TMP_DIR)\tclXfstat.obj \ $(TMP_DIR)\tclXgeneral.obj \ $(TMP_DIR)\tclXhandles.obj \ $(TMP_DIR)\tclXinit.obj \ $(TMP_DIR)\tclXkeylist.obj \ $(TMP_DIR)\tclXlib.obj \ $(TMP_DIR)\tclXlist.obj \ $(TMP_DIR)\tclXmath.obj \ $(TMP_DIR)\tclXmsgcat.obj \ $(TMP_DIR)\tclXprocess.obj \ $(TMP_DIR)\tclXprofile.obj \ $(TMP_DIR)\tclXselect.obj \ $(TMP_DIR)\tclXsignal.obj \ $(TMP_DIR)\tclXstring.obj \ $(TMP_DIR)\tclXsocket.obj \ $(TMP_DIR)\tclXutil.obj \ $(TMP_DIR)\tclXoscmds.obj \ $(TMP_DIR)\tclXlgets.obj \ $(TMP_DIR)\tclXwinCmds.obj \ $(TMP_DIR)\tclXwinDup.obj \ $(TMP_DIR)\tclXwinId.obj \ $(TMP_DIR)\tclXwinOS.obj \ $(TMP_DIR)\random.obj \ $(TMP_DIR)\getopt.obj \ !if !$(STATIC_BUILD) $(TMP_DIR)\tclx.res !endif #------------------------------------------------------------------------- # Target names and paths ( shouldn't need changing ) #------------------------------------------------------------------------- BINROOT = . ROOT = .. PRJIMPLIB = $(OUT_DIR)\$(PROJECT)$(VERSION)$(SUFX).lib PRJLIBNAME = $(PROJECT)$(VERSION)$(SUFX).$(EXT) PRJLIB = $(OUT_DIR)\$(PRJLIBNAME) PRJSTUBLIBNAME = $(STUBPREFIX)$(VERSION).lib PRJSTUBLIB = $(OUT_DIR)\$(PRJSTUBLIBNAME) ### Make sure we use backslash only. PRJ_INSTALL_DIR = $(_INSTALLDIR)\$(PROJECT)$(DOTVERSION) LIB_INSTALL_DIR = $(PRJ_INSTALL_DIR) BIN_INSTALL_DIR = $(PRJ_INSTALL_DIR) DOC_INSTALL_DIR = $(PRJ_INSTALL_DIR) SCRIPT_INSTALL_DIR = $(PRJ_INSTALL_DIR) INCLUDE_INSTALL_DIR = $(_TCLDIR)\include ### The following paths CANNOT have spaces in them. GENERICDIR = $(ROOT)\generic WINDIR = $(ROOT)\win LIBDIR = $(ROOT)\library DOCDIR = $(ROOT)\doc TOOLSDIR = $(ROOT)\tools COMPATDIR = $(ROOT)\compat #--------------------------------------------------------------------- # Compile flags #--------------------------------------------------------------------- !if !$(DEBUG) !if $(OPTIMIZING) ### This cranks the optimization level to maximize speed cdebug = $(OPTIMIZATIONS) !else cdebug = !endif !else if "$(MACHINE)" == "IA64" || "$(MACHINE)" == "AMD64" ### Warnings are too many, can't support warnings into errors. cdebug = -Zi -Od $(DEBUGFLAGS) !else cdebug = -Zi -WX $(DEBUGFLAGS) !endif ### Declarations common to all compiler options cwarn = $(WARNINGS) -D _CRT_SECURE_NO_DEPRECATE -D _CRT_NONSTDC_NO_DEPRECATE cflags = -nologo -c $(COMPILERFLAGS) $(cwarn) -Fp$(TMP_DIR)^\ !if $(MSVCRT) !if $(DEBUG) && !$(UNCHECKED) crt = -MDd !else crt = -MD !endif !else !if $(DEBUG) && !$(UNCHECKED) crt = -MTd !else crt = -MT !endif !endif !if !$(STATIC_BUILD) cflags = $(cflags) -DUSE_TCL_STUBS !if defined(TKSTUBLIB) cflags = $(cflags) -DUSE_TK_STUBS !endif !endif INCLUDES = $(TCL_INCLUDES) -I"$(WINDIR)" -I"$(GENERICDIR)" BASE_CFLAGS = $(cflags) $(cdebug) $(crt) $(INCLUDES) CON_CFLAGS = $(cflags) $(cdebug) $(crt) -DCONSOLE TCL_CFLAGS = -DPACKAGE_NAME="\"$(PROJECT)\"" \ -DPACKAGE_VERSION="\"$(DOTVERSION)\"" \ -DBUILD_$(PROJECT) -DWIN32 \ -DFULL_VERSION="\"$(FULL_VERSION)\"" \ $(BASE_CFLAGS) $(OPTDEFINES) #--------------------------------------------------------------------- # Link flags #--------------------------------------------------------------------- !if $(DEBUG) ldebug = -debug:full -debugtype:cv !if $(MSVCRT) ldebug = $(ldebug) -nodefaultlib:msvcrt !endif !else ldebug = -release -opt:ref -opt:icf,3 !endif ### Declarations common to all linker options lflags = -nologo -machine:$(MACHINE) $(LINKERFLAGS) $(ldebug) !if $(PROFILE) lflags = $(lflags) -profile !endif !if $(ALIGN98_HACK) && !$(STATIC_BUILD) ### Align sections for PE size savings. lflags = $(lflags) -opt:nowin98 !else if !$(ALIGN98_HACK) && $(STATIC_BUILD) ### Align sections for speed in loading by choosing the virtual page size. lflags = $(lflags) -align:4096 !endif !if $(LOIMPACT) lflags = $(lflags) -ws:aggressive !endif dlllflags = $(lflags) -dll conlflags = $(lflags) -subsystem:console guilflags = $(lflags) -subsystem:windows !if !$(STATIC_BUILD) baselibs = $(TCLSTUBLIB) !if defined(TKSTUBLIB) baselibs = $(baselibs) $(TKSTUBLIB) !endif !endif # Avoid 'unresolved external symbol __security_cookie' errors. # c.f. http://support.microsoft.com/?id=894573 !if "$(MACHINE)" == "IA64" || "$(MACHINE)" == "AMD64" !if $(VCVERSION) >= 1400 && $(VCVERSION) < 1500 baselibs = $(baselibs) bufferoverflowU.lib !endif !endif baselibs = $(baselibs) ws2_32.lib #--------------------------------------------------------------------- # TclTest flags #--------------------------------------------------------------------- !IF "$(TESTPAT)" != "" TESTFLAGS = $(TESTFLAGS) -file $(TESTPAT) !ENDIF #--------------------------------------------------------------------- # Project specific targets (EDIT) #--------------------------------------------------------------------- all: setup $(PROJECT) $(PROJECT): setup pkgIndex $(PRJLIB) install: install-binaries install-libraries install-docs pkgIndex: $(OUT_DIR)\pkgIndex.tcl test: setup $(PROJECT) @set TCL_LIBRARY=$(TCL_LIBRARY:\=/) @set TCLLIBPATH=$(OUT_DIR_PATH:\=/) !if $(TCLINSTALL) @set PATH=$(_TCLDIR)\bin;$(PATH) !else @set PATH=$(_TCLDIR)\win\$(BUILDDIRTOP);$(PATH) !endif @$(CPY) $(LIBDIR) $(OUT_DIR)\tclx8.4 !if "$(OS)" == "Windows_NT" || "$(MSVCDIR)" == "IDE" $(DEBUGGER) $(TCLSH) "$(ROOT)/tests/all.tcl" $(TESTFLAGS) !else @echo Please wait while the tests are collected... $(DEBUGGER) $(TCLSH) "$(ROOT)/tests/all.tcl" $(TESTFLAGS) > tests.log type tests.log | more !endif shell: setup $(PROJECT) @set TCL_LIBRARY=$(TCL_LIBRARY:\=/) @set TCLLIBPATH=$(OUT_DIR_PATH:\=/) !if $(TCLINSTALL) @set PATH=$(_TCLDIR)\bin;$(PATH) !else @set PATH=$(_TCLDIR)\win\$(BUILDDIRTOP);$(PATH) !endif @$(CPY) $(LIBDIR) $(OUT_DIR)\tclx8.4 $(DEBUGGER) $(TCLSH) $(SCRIPT) setup: @if not exist $(OUT_DIR)\nul mkdir $(OUT_DIR) @if not exist $(TMP_DIR)\nul mkdir $(TMP_DIR) # See /win/coffbase.txt for extension base addresses. $(PRJLIB): $(DLLOBJS) !if $(STATIC_BUILD) $(lib32) -nologo -out:$@ @<< $** << !else $(link32) $(dlllflags) -base:0x10000000 -out:$@ $(baselibs) @<< $** << $(_VC_MANIFEST_EMBED_DLL) -@del $*.exp !endif $(PRJSTUBLIB): $(PRJSTUBOBJS) $(lib32) -nologo -out:$@ $(PRJSTUBOBJS) #--------------------------------------------------------------------- # Implicit rules #--------------------------------------------------------------------- {$(WINDIR)}.c{$(TMP_DIR)}.obj:: $(cc32) $(TCL_CFLAGS) -DBUILD_$(PROJECT) -Fo$(TMP_DIR)\ @<< $< << {$(GENERICDIR)}.c{$(TMP_DIR)}.obj:: $(cc32) $(TCL_CFLAGS) -DBUILD_$(PROJECT) -Fo$(TMP_DIR)\ @<< $< << {$(COMPATDIR)}.c{$(TMP_DIR)}.obj:: $(cc32) $(TCL_CFLAGS) -DBUILD_$(PROJECT) -Fo$(TMP_DIR)\ @<< $< << {$(WINDIR)}.rc{$(TMP_DIR)}.res: $(rc32) -fo $@ -r -i "$(GENERICDIR)" -D__WIN32__ \ -DCOMMAVERSION=$(DOTVERSION:.=,),0,0 \ -DDOTVERSION=\"$(DOTVERSION)\" \ -DVERSION=\"$(VERSION)$(SUFX)\" \ !if $(DEBUG) -d DEBUG \ !endif !if $(TCL_THREADS) -d TCL_THREADS \ !endif !if $(STATIC_BUILD) -d STATIC_BUILD \ !endif $< .SUFFIXES: .SUFFIXES:.c .rc #------------------------------------------------------------------------- # Explicit dependency rules # #------------------------------------------------------------------------- $(OUT_DIR)\pkgIndex.tcl: $(WINDIR)\pkgIndex.tcl.in @nmakehlp -s << $** > $@ @PACKAGE_VERSION@ $(DOTVERSION) @PACKAGE_NAME@ $(PROJECT) @PKG_LIB_FILE@ $(PRJLIBNAME) << #--------------------------------------------------------------------- # Installation. (EDIT) # # You may need to modify this section to reflect the final distribution # of your files and possibly to generate documentation. # #--------------------------------------------------------------------- install-binaries: @echo Installing binaries to '$(SCRIPT_INSTALL_DIR)' @if not exist "$(SCRIPT_INSTALL_DIR)" mkdir "$(SCRIPT_INSTALL_DIR)" @$(CPY) $(PRJLIB) "$(SCRIPT_INSTALL_DIR)" >NUL install-libraries: $(OUT_DIR)\pkgIndex.tcl @echo Installing libraries to '$(SCRIPT_INSTALL_DIR)' @if exist $(LIBDIR) $(CPY) $(LIBDIR)\*.tcl "$(SCRIPT_INSTALL_DIR)" @echo Installing package index in '$(SCRIPT_INSTALL_DIR)' @$(CPY) $(OUT_DIR)\pkgIndex.tcl $(SCRIPT_INSTALL_DIR) install-docs: @echo Installing documentation files to '$(DOC_INSTALL_DIR)' @if exist $(DOCDIR) $(CPY) $(DOCDIR)\*.n "$(DOC_INSTALL_DIR)" #--------------------------------------------------------------------- # Clean up #--------------------------------------------------------------------- clean: @if exist $(TMP_DIR)\nul $(RMDIR) $(TMP_DIR) @if exist $(WINDIR)\version.vc del $(WINDIR)\version.vc @if exist $(WINDIR)\vercl.i del $(WINDIR)\vercl.i @if exist $(WINDIR)\vercl.x del $(WINDIR)\vercl.x @if exist $(WINDIR)\_junk.pch del $(WINDIR)\_junk.pch realclean: clean @if exist $(OUT_DIR)\nul $(RMDIR) $(OUT_DIR) distclean: realclean @if exist $(WINDIR)\nmakehlp.exe del $(WINDIR)\nmakehlp.exe @if exist $(WINDIR)\nmakehlp.obj del $(WINDIR)\nmakehlp.obj tclx8.4-8.4.1.orig/win/tclx.rc0000644000000000000000000000220512046313170012646 0ustar /* tclx.rc - Copyright (C) 2007 Pat Thoyts * * Extended Tcl package * * See the file "LICENSE" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * * $Id: tclx.rc,v 8.1 2008/06/29 23:53:57 patthoyts Exp $ */ #include VS_VERSION_INFO VERSIONINFO FILEVERSION COMMAVERSION PRODUCTVERSION COMMAVERSION FILEFLAGSMASK 0x3fL #ifdef DEBUG FILEFLAGS VS_FF_DEBUG #else FILEFLAGS 0x0L #endif FILEOS VOS__WINDOWS32 FILETYPE VFT_DLL FILESUBTYPE 0x0L BEGIN BLOCK "StringFileInfo" BEGIN BLOCK "040904b0" BEGIN VALUE "FileDescription", "Extended Tcl (TclX)" DOTVERSION "\0" VALUE "OriginalFilename", "tclx" VERSION ".dll\0" VALUE "FileVersion", DOTVERSION "\0" VALUE "LegalCopyright", "Copyright \251 1991-1999 Karl Lehenbauer and Mark Diekhans\0" VALUE "ProductName", "Extended Tcl " DOTVERSION "\0" VALUE "ProductVersion", DOTVERSION "\0" END END BLOCK "VarFileInfo" BEGIN VALUE "Translation", 0x409, 1200 END END tclx8.4-8.4.1.orig/win/tclXwinTest.c0000644000000000000000000000503212046313170014003 0ustar /* * tclXwinTest.c -- * * Provides a test version of the Tcl_AppInit procedure for use with * applications built with Extended Tcl on Windows 95/NT systems. *----------------------------------------------------------------------------- * Copyright 1991-1999 Karl Lehenbauer and Mark Diekhans. * * Permission to use, copy, modify, and distribute this software and its * documentation for any purpose and without fee is hereby granted, provided * that the above copyright notice appear in all copies. Karl Lehenbauer and * Mark Diekhans make no representations about the suitability of this * software for any purpose. It is provided "as is" without express or * implied warranty. *----------------------------------------------------------------------------- * $Id: tclXwinTest.c,v 1.1 2001/10/24 23:31:50 hobbs Exp $ *----------------------------------------------------------------------------- */ #include "tclExtend.h" extern int Tcltest_Init (Tcl_Interp *interp); extern int Tclxtest_Init (Tcl_Interp *interp); /*----------------------------------------------------------------------------- * main -- * * This is the main program for the application. *----------------------------------------------------------------------------- */ int main (int argc, char **argv) { TclX_Main (argc, argv, Tcl_AppInit); return 0; /* Needed only to prevent compiler warning. */ } /*----------------------------------------------------------------------------- * Tcl_AppInit -- * * This procedure performs application-specific initialization. Most * applications, especially those that incorporate additional packages, will * have their own version of this procedure. * * Results: * Returns a standard Tcl completion code, and leaves an error message in * interp result if an error occurs. *----------------------------------------------------------------------------- */ int Tcl_AppInit (Tcl_Interp *interp) { if (Tcl_Init (interp) == TCL_ERROR) { return TCL_ERROR; } if (Tclx_Init (interp) == TCL_ERROR) { return TCL_ERROR; } Tcl_StaticPackage (interp, "Tclx", Tclx_Init, Tclx_SafeInit); if (Tcltest_Init (interp) == TCL_ERROR) { return TCL_ERROR; } Tcl_StaticPackage(interp, "Tcltest", Tcltest_Init, (Tcl_PackageInitProc *) NULL); if (Tclxtest_Init (interp) == TCL_ERROR) { return TCL_ERROR; } Tcl_StaticPackage(interp, "Tclxtest", Tclxtest_Init, (Tcl_PackageInitProc *) NULL); return TCL_OK; } tclx8.4-8.4.1.orig/win/tclXwinOS.c0000644000000000000000000015646512046313170013426 0ustar /* * tclXwinOS.c -- * * OS system dependent interface for Windows systems. The idea behind these * functions is to provide interfaces to various functions that vary on the * various platforms. These functions either implement the call in a manner * approriate to the platform or return an error indicating the functionality * is not available on that platform. This results in code with minimal * number of #ifdefs. *----------------------------------------------------------------------------- * Copyright 1996-1999 Karl Lehenbauer and Mark Diekhans. * * Permission to use, copy, modify, and distribute this software and its * documentation for any purpose and without fee is hereby granted, provided * that the above copyright notice appear in all copies. Karl Lehenbauer and * Mark Diekhans make no representations about the suitability of this * software for any purpose. It is provided "as is" without express or * implied warranty. *----------------------------------------------------------------------------- * $Id: tclXwinOS.c,v 1.8 2005/07/12 19:03:15 hobbs Exp $ *----------------------------------------------------------------------------- * The code for reading directories is based on TclMatchFiles from the Tcl * distribution file win/tclWinFile.c * Copyright (c) 1995 Sun Microsystems, Inc. *----------------------------------------------------------------------------- */ #include "tclExtdInt.h" typedef enum { TCLX_WIN_CONSOLE, TCLX_WIN_FILE, TCLX_WIN_PIPE, TCLX_WIN_SOCKET } tclXwinFileType; /*----------------------------------------------------------------------------- * TclXNotAvailableError -- * Return an error about functionality not being available under Windows. * * Parameters: * o interp - Errors returned in result. * o funcName - Command or other name to use in not available error. * Returns: * TCL_ERROR. *----------------------------------------------------------------------------- */ int TclXNotAvailableError (Tcl_Interp *interp, char *funcName) { Tcl_AppendResult(interp, funcName, " is not available on MS Windows", (char *) NULL); return TCL_ERROR; } int TclXNotAvailableObjError (Tcl_Interp *interp, Tcl_Obj *obj) { char *funcName = Tcl_GetStringFromObj(obj, NULL); Tcl_AppendResult(interp, funcName, " is not available on MS Windows", (char *) NULL); return TCL_ERROR; } /*----------------------------------------------------------------------------- * TclX_SplitWinCmdLine -- * Parse the window command line into arguments. * * Parameters: * o argcPtr - Count of arguments is returned here. * o argvPtr - Argument vector is returned here. * Notes: * This code taken from the Tcl file tclAppInit.c: Copyright (c) 1996 by * Sun Microsystems, Inc. *----------------------------------------------------------------------------- */ /* *------------------------------------------------------------------------- * * setargv -- * * Parse the Windows command line string into argc/argv. Done here * because we don't trust the builtin argument parser in crt0. * Windows applications are responsible for breaking their command * line into arguments. * * 2N backslashes + quote -> N backslashes + begin quoted string * 2N + 1 backslashes + quote -> literal * N backslashes + non-quote -> literal * quote + quote in a quoted string -> single quote * quote + quote not in quoted string -> empty string * quote -> begin quoted string * * Results: * Fills argcPtr with the number of arguments and argvPtr with the * array of arguments. * * Side effects: * Memory allocated. * *-------------------------------------------------------------------------- */ void TclX_SplitWinCmdLine (int *argcPtr, char ***argvPtr) { char *cmdLine, *p, *arg, *argSpace; char **argv; int argc, size, inquote, copy, slashes; cmdLine = GetCommandLine(); /* * Precompute an overly pessimistic guess at the number of arguments * in the command line by counting non-space spans. */ size = 2; for (p = cmdLine; *p != '\0'; p++) { if (isspace(*p)) { size++; while (isspace(*p)) { p++; } if (*p == '\0') { break; } } } argSpace = (char *) ckalloc((unsigned) (size * sizeof(char *) + strlen(cmdLine) + 1)); argv = (char **) argSpace; argSpace += size * sizeof(char *); size--; p = cmdLine; for (argc = 0; argc < size; argc++) { argv[argc] = arg = argSpace; while (isspace(*p)) { p++; } if (*p == '\0') { break; } inquote = 0; slashes = 0; while (1) { copy = 1; while (*p == '\\') { slashes++; p++; } if (*p == '"') { if ((slashes & 1) == 0) { copy = 0; if ((inquote) && (p[1] == '"')) { p++; copy = 1; } else { inquote = !inquote; } } slashes >>= 1; } while (slashes) { *arg = '\\'; arg++; slashes--; } if ((*p == '\0') || (!inquote && isspace(*p))) { break; } if (copy != 0) { *arg = *p; arg++; } p++; } *arg = '\0'; argSpace = arg + 1; } argv[argc] = NULL; *argcPtr = argc; *argvPtr = argv; } /*----------------------------------------------------------------------------- * ChannelToHandle -- * * Convert a channel to a handle. * * Parameters: * o channel - Channel to get file number for. * o direction - TCL_READABLE or TCL_WRITABLE, or zero. If zero, then * return the first of the read and write numbers. * o type - The type of the file. not set if an error occurs. * * Returns: * The file handle or INVALID_HANDLE_VALUE if a HANDLE is not associated * with this access direction, or if the channel does not have a HANDLE * of the Windows variety. We hope that the channel driver does not return * a HANDLE that we cannot use. *----------------------------------------------------------------------------- */ static HANDLE ChannelToHandle (Tcl_Channel channel, int direction, tclXwinFileType *typePtr) { ClientData handle; int sockType; int sockTypeLen = sizeof(sockType); if (direction == 0) { if (Tcl_GetChannelHandle (channel, TCL_READABLE, &handle) != TCL_OK && Tcl_GetChannelHandle (channel, TCL_WRITABLE, &handle) != TCL_OK) { handle = INVALID_HANDLE_VALUE; } } else { if (Tcl_GetChannelHandle (channel, direction, &handle) != TCL_OK) { handle = INVALID_HANDLE_VALUE; } } /* * Call GetFileType() even on invalid handles to set errno, * also will coerce INVALID_SOCKET to INVALID_HANDLE, they * may not be the same on some machines. */ switch (GetFileType ((HANDLE) handle)) { case FILE_TYPE_DISK: *typePtr = TCLX_WIN_FILE; break; case FILE_TYPE_CHAR: *typePtr = TCLX_WIN_CONSOLE; break; case FILE_TYPE_PIPE: if (getsockopt ((SOCKET)handle, SOL_SOCKET, SO_TYPE, (void *)&sockType, &sockTypeLen) == 0) { *typePtr = TCLX_WIN_SOCKET; } else { *typePtr = TCLX_WIN_PIPE; } break; case FILE_TYPE_UNKNOWN: handle = INVALID_HANDLE_VALUE; break; } return (HANDLE) handle; } /*----------------------------------------------------------------------------- * ChannelToSocket -- * * Convert a channel to a socket. * * Parameters: * o interp - An error is returned if the channel is not a socket. * o channel - Channel to get file number for. * Returns: * The socket number or INVALID_SOCKET if an error occurs. *----------------------------------------------------------------------------- */ static SOCKET ChannelToSocket (Tcl_Interp *interp, Tcl_Channel channel) { ClientData handle; tclXwinFileType type; handle = ChannelToHandle(channel, 0, &type); if (handle == INVALID_HANDLE_VALUE || type != TCLX_WIN_SOCKET) { TclX_AppendObjResult (interp, "channel \"", Tcl_GetChannelName (channel), "\" is not a socket", (char *) NULL); return INVALID_SOCKET; } return (SOCKET) handle; } /*----------------------------------------------------------------------------- * ConvertToUnixTime -- * * Convert a FILETIME structure to Unix style time. * * Parameters: * o fileTime - Time to convert. * Returns: * Unix time: seconds since Jan 1, 1970. *----------------------------------------------------------------------------- */ static time_t ConvertToUnixTime (FILETIME fileTime) { /* FIX: Write me */ return 0; } /*----------------------------------------------------------------------------- * TclXOSgetpriority -- * System dependent interface to getpriority functionality, which is not * available* on windows. * * Parameters: * o interp - Errors returned in result. * o priority - Process priority is returned here. * o funcName - Command or other name to use in not available error. * Results: * TCL_ERROR. *----------------------------------------------------------------------------- */ int TclXOSgetpriority (Tcl_Interp *interp, int *priority, char *funcName) { /*FIX: this should work */ return TclXNotAvailableError (interp, funcName); } /*----------------------------------------------------------------------------- * TclXOSincrpriority-- * System dependent interface to increment or decrement the current priority, * which is not available on windows. * * Parameters: * o interp - Errors returned in result. * o priorityIncr - Amount to adjust the priority by. * o priority - The new priority.. * o funcName - Command or other name to use in not available error. * Results: * TCL_ERROR. *----------------------------------------------------------------------------- */ int TclXOSincrpriority (Tcl_Interp *interp, int priorityIncr, int *priority, char *funcName) { return TclXNotAvailableError (interp, funcName); } /*----------------------------------------------------------------------------- * TclXOSpipe -- * System dependent interface to create a pipes for the pipe command. * * Parameters: * o interp - Errors returned in result. * o channels - Two element array to return read and write channels in. * Results: * TCL_OK or TCL_ERROR. *----------------------------------------------------------------------------- */ int TclXOSpipe (interp, channels) Tcl_Interp *interp; Tcl_Channel *channels; { HANDLE readHandle, writeHandle; SECURITY_ATTRIBUTES sec; sec.nLength = sizeof(SECURITY_ATTRIBUTES); sec.lpSecurityDescriptor = NULL; sec.bInheritHandle = FALSE; if (!CreatePipe (&readHandle, &writeHandle, &sec, 0)) { TclWinConvertError (GetLastError ()); TclX_AppendObjResult (interp, "pipe creation failed: ", Tcl_PosixError (interp), (char *) NULL); return TCL_ERROR; } channels [0] = Tcl_MakeFileChannel ((ClientData) readHandle, TCL_READABLE); Tcl_RegisterChannel (interp, channels [0]); channels [1] = Tcl_MakeFileChannel ((ClientData) writeHandle, TCL_WRITABLE); Tcl_RegisterChannel (interp, channels [1]); return TCL_OK; } /*----------------------------------------------------------------------------- * TclXOSsetitimer -- * System dependent interface to setitimer functionality, which is not * available on windows. * * Parameters: * o interp - Errors returned in result. * o seconds (I/O) - Seconds to pause for, it is updated with the time * remaining on the last alarm. * o funcName - Command or other name to use in not available error. * Results: * TCL_ERROR. *----------------------------------------------------------------------------- */ int TclXOSsetitimer (Tcl_Interp *interp, double *seconds, char *funcName) { return TclXNotAvailableError (interp, funcName); } /*----------------------------------------------------------------------------- * TclXOSsleep -- * System dependent interface to sleep functionality. * * Parameters: * o seconds - Seconds to sleep. *----------------------------------------------------------------------------- */ void TclXOSsleep (unsigned seconds) { Tcl_Sleep(seconds*1000); } /*----------------------------------------------------------------------------- * TclXOSsync -- * System dependent interface to sync functionality. *----------------------------------------------------------------------------- */ void TclXOSsync () { _flushall (); } /*----------------------------------------------------------------------------- * TclXOSfsync -- * System dependent interface to fsync functionality. Does a _flushall, * since fsync is not available. * * Parameters: * o interp - Errors returned in result. * o channel - The channel to sync. * Results: * TCL_OK or TCL_ERROR. *----------------------------------------------------------------------------- */ int TclXOSfsync (Tcl_Interp *interp, Tcl_Channel channel) { if (Tcl_Flush (channel) < 0) goto posixError; _flushall (); return TCL_OK; posixError: TclX_AppendObjResult (interp, Tcl_PosixError (interp), (char *) NULL); return TCL_ERROR; } /*----------------------------------------------------------------------------- * TclXOSsystem -- * System dependent interface to system functionality (executing a command * with the standard system shell). * * Parameters: * o interp - Errors returned in result. * o command - Command to execute. * o exitCode - Exit code of the child process. * Results: * TCL_OK or TCL_ERROR. *----------------------------------------------------------------------------- */ int TclXOSsystem (Tcl_Interp *interp, char *command, int *exitCode) { PROCESS_INFORMATION pi; STARTUPINFO si; BOOL bSuccess; memset (&si, 0, sizeof (si)); bSuccess = CreateProcess (command, NULL, NULL, NULL, 0, CREATE_NEW_PROCESS_GROUP, NULL, NULL, &si, &pi); if (!bSuccess) { TclX_AppendObjResult (interp, "process creation failed", (char *) NULL); return TCL_ERROR; } CloseHandle (pi.hThread); WaitForSingleObject (pi.hProcess, INFINITE); GetExitCodeProcess (pi.hProcess, exitCode); CloseHandle (pi.hProcess); return TCL_OK; } /*----------------------------------------------------------------------------- * TclX_OSlink -- * * System dependent interface to link functionality, which is not * available on windows. * * Parameters: * o interp - Errors returned in result. * o srcPath - File to link. * o targetPath - Path to new link. * o funcName - Command or other name to use in not available error. * Results: * TCL_ERROR. *----------------------------------------------------------------------------- */ int TclX_OSlink (Tcl_Interp *interp, char *srcPath, char *targetPath, char *funcName) { return TclXNotAvailableError (interp, funcName); } /*----------------------------------------------------------------------------- * TclX_OSsymlink -- * System dependent interface to symlink functionality. * * Parameters: * o interp - Errors returned in result. * o srcPath - Value of symbolic link. * o targetPath - Path to new symbolic link. * o funcName - Command or other name to use in not available error. * Results: * TCL_ERROR. *----------------------------------------------------------------------------- */ int TclX_OSsymlink (Tcl_Interp *interp, char *srcPath, char *targetPath, char *funcName) { /* FIX: make an alias */ return TclXNotAvailableError (interp, funcName); } /*----------------------------------------------------------------------------- * TclXOSElapsedTime -- * System dependent interface to get the elapsed CPU and real time. CPU time * is not available under windows and zero is always returned. * * Parameters: * o realTime - Elapsed real time, in milliseconds is returned here. * o cpuTime - Elapsed CPU time, zero is always returned. *----------------------------------------------------------------------------- */ void TclXOSElapsedTime (clock_t *realTime, clock_t *cpuTime) { static DWORD startTime = 0; /* * If this is the first call, get base time. */ if (startTime == 0) { startTime = GetTickCount (); } *realTime = GetTickCount () - startTime; *cpuTime = 0; } /*----------------------------------------------------------------------------- * TclXOSkill -- * System dependent interface to terminate a process. Apparently, * it's not possible to send a specific signal in windows? * * Parameters: * o interp - Errors returned in result. * o pid - Process id, negative process group, etc. * o signal - Signal to send. * o funcName - Command or other name to use in not available error. * Results: * TCL_ERROR. *----------------------------------------------------------------------------- */ int TclXOSkill (Tcl_Interp *interp, pid_t pid, int signal, char *funcName) { HANDLE processHandle; processHandle = OpenProcess(PROCESS_TERMINATE, FALSE, (int) pid); if (processHandle == NULL) { Tcl_AppendResult(interp, "invalid pid", (char *) NULL); return TCL_ERROR; } TerminateProcess(processHandle, 7); CloseHandle(processHandle); return TCL_OK; } /*----------------------------------------------------------------------------- * TclXOSFstat -- * System dependent interface to get status information on an open file. * * Parameters: * o interp - Errors are returned in result. * o channel - Channel to get file number for. * o statBuf - Status information, made to look as much like Unix as * possible. * o ttyDev - If not NULL, a boolean indicating if the device is * associated with a tty. (Always FALSE on windows). * Results: * TCL_OK or TCL_ERROR. *----------------------------------------------------------------------------- */ int TclXOSFstat (Tcl_Interp *interp, Tcl_Channel channel, struct stat *statBuf, int *ttyDev) { HANDLE handle; tclXwinFileType type; FILETIME creation, access, modify; /* FIX: More of this information is availiable from * GetFileInformationByHandle */ handle = ChannelToHandle (channel, 0, &type); if (handle == INVALID_HANDLE_VALUE) { TclX_AppendObjResult (interp, "channel \"", Tcl_GetChannelName (channel), "\" has no device handle", (char *) NULL); return TCL_ERROR; } /* * These don't translate to windows. */ statBuf->st_dev = 0; statBuf->st_ino = 0; statBuf->st_rdev = 0; statBuf->st_mode = 0; switch (type) { case TCLX_WIN_PIPE: statBuf->st_mode |= S_IFIFO; break; case TCLX_WIN_FILE: statBuf->st_mode |= S_IFREG; break; case TCLX_WIN_SOCKET: statBuf->st_mode |= S_IFSOCK; break; case TCLX_WIN_CONSOLE: statBuf->st_mode |= S_IFCHR; break; } statBuf->st_nlink = (type == TCLX_WIN_FILE) ? 1 : 0; statBuf->st_uid = 0; /* FIX??? */ statBuf->st_gid = 0; switch (type) { case TCLX_WIN_FILE: case TCLX_WIN_PIPE: statBuf->st_size = GetFileSize (handle, NULL); if (statBuf->st_size < 0) goto winError; if (!GetFileTime (handle, &creation, &access, &modify)) { goto winError; } statBuf->st_atime = ConvertToUnixTime (creation); statBuf->st_mtime = ConvertToUnixTime (access); statBuf->st_ctime = ConvertToUnixTime (modify); break; case TCLX_WIN_SOCKET: case TCLX_WIN_CONSOLE: statBuf->st_size = 0; statBuf->st_atime = 0; statBuf->st_mtime = 0; statBuf->st_ctime = 0; break; } if (ttyDev != NULL) *ttyDev = (type == TCLX_WIN_CONSOLE) ? 1 : 0; return TCL_OK; winError: TclWinConvertError (GetLastError ()); TclX_AppendObjResult (interp, Tcl_PosixError (interp), (char *) NULL); return TCL_ERROR; } /*----------------------------------------------------------------------------- * TclXOSWalkDir -- * System dependent interface to reading the contents of a directory. The * specified directory is walked and a callback is called on each entry. * The "." and ".." entries are skipped. * * Parameters: * o interp - Interp to return errors in. * o path - Path to the directory. * o hidden - Include hidden files. Ignored on Unix. * o callback - Callback function to call on each directory entry. * It should return TCL_OK to continue processing, TCL_ERROR if an * error occured and TCL_BREAK to stop processing. The parameters are: * o interp - Interp is passed though. * o path - Normalized path to directory. * o fileName - Tcl normalized file name in directory. * o caseSensitive - Are the file names case sensitive? * o clientData - Client data that was passed. * o clientData - Client data to pass to callback. * Results: * TCL_OK if completed directory walk. TCL_BREAK if callback returned * TCL_BREAK and TCL_ERROR if an error occured. *----------------------------------------------------------------------------- */ int TclXOSWalkDir (Tcl_Interp *interp, char *path, int hidden, TclX_WalkDirProc *callback, ClientData clientData) { char drivePattern[4] = "?:\\"; char *p, *dir, *root, c; int result = TCL_OK; Tcl_DString pathBuf; DWORD atts, volFlags; HANDLE handle; WIN32_FIND_DATA data; BOOL found; /* * Convert the path to normalized form since some interfaces only * accept backslashes. Also, ensure that the directory ends with a * separator character. */ Tcl_DStringInit (&pathBuf); Tcl_DStringAppend (&pathBuf, path, -1); if (Tcl_DStringLength (&pathBuf) == 0) { Tcl_DStringAppend (&pathBuf, ".", 1); } for (p = Tcl_DStringValue( &pathBuf); *p != '\0'; p++) { if (*p == '/') { *p = '\\'; } } p--; if (*p != '\\' && *p != ':') { Tcl_DStringAppend(&pathBuf, "\\", 1); } dir = Tcl_DStringValue(&pathBuf); /* * First verify that the specified path is actually a directory. */ atts = GetFileAttributes (dir); if ((atts == 0xFFFFFFFF) || ((atts & FILE_ATTRIBUTE_DIRECTORY) == 0)) { Tcl_DStringFree (&pathBuf); return TCL_OK; } /* * Next check the volume information for the directory to see whether * comparisons should be case sensitive or not. If the root is null, then * we use the root of the current directory. If the root is just a drive * specifier, we use the root directory of the given drive. */ switch (Tcl_GetPathType (dir)) { case TCL_PATH_RELATIVE: found = GetVolumeInformation (NULL, NULL, 0, NULL, NULL, &volFlags, NULL, 0); break; case TCL_PATH_VOLUME_RELATIVE: if (*dir == '\\') { root = NULL; } else { root = drivePattern; *root = *dir; } found = GetVolumeInformation (root, NULL, 0, NULL, NULL, &volFlags, NULL, 0); break; case TCL_PATH_ABSOLUTE: if (dir[1] == ':') { root = drivePattern; *root = *dir; found = GetVolumeInformation (root, NULL, 0, NULL, NULL, &volFlags, NULL, 0); } else if (dir[1] == '\\') { p = strchr(dir+2, '\\'); p = strchr(p+1, '\\'); p++; c = *p; *p = 0; found = GetVolumeInformation (dir, NULL, 0, NULL, NULL, &volFlags, NULL, 0); *p = c; } break; } if (!found) { Tcl_DStringFree (&pathBuf); TclWinConvertError (GetLastError ()); Tcl_ResetResult (interp); TclX_AppendObjResult (interp, "couldn't read volume information for \"", path, "\": ", Tcl_PosixError (interp), (char *) NULL); return TCL_ERROR; } /* * We need to check all files in the directory, so append a *.* * to the path. */ dir = Tcl_DStringAppend (&pathBuf, "*.*", 3); /* * Now open the directory for reading and iterate over the contents. */ handle = FindFirstFile (dir, &data); Tcl_DStringFree (&pathBuf); if (handle == INVALID_HANDLE_VALUE) { TclWinConvertError (GetLastError ()); Tcl_ResetResult (interp); TclX_AppendObjResult (interp, "couldn't read directory \"", path, "\": ", Tcl_PosixError (interp), (char *) NULL); return TCL_ERROR; } /* * Now iterate over all of the files in the directory. */ for (found = 1; found; found = FindNextFile (handle, &data)) { /* * Ignore hidden files if not requested. */ if ((data.dwFileAttributes & FILE_ATTRIBUTE_HIDDEN) && !hidden) continue; /* * Skip "." and "..". */ if (STREQU (data.cFileName, ".") || STREQU (data.cFileName, "..")) continue; /* * Call the callback with this file. */ result = (*callback) (interp, path, data.cFileName, (volFlags & FS_CASE_SENSITIVE), clientData); if (!((result == TCL_OK) || (result == TCL_CONTINUE))) break; } Tcl_DStringFree (&pathBuf); FindClose (handle); return result; } /*----------------------------------------------------------------------------- * TclXOSGetFileSize -- * System dependent interface to get the size of an open file. * * Parameters: * o channel - Channel. * o fileSize - File size is returned here. * Results: * TCL_OK or TCL_ERROR. A POSIX error will be set. *----------------------------------------------------------------------------- */ int TclXOSGetFileSize (Tcl_Channel channel, off_t *fileSize) { HANDLE handle; tclXwinFileType type; handle = ChannelToHandle (channel, 0, &type); if (handle == INVALID_HANDLE_VALUE) { return TCL_ERROR; } switch (type) { case TCLX_WIN_PIPE: case TCLX_WIN_FILE: *fileSize = GetFileSize (handle, NULL); if (*fileSize < 0) { TclWinConvertError (GetLastError ()); return TCL_ERROR; } break; case TCLX_WIN_SOCKET: case TCLX_WIN_CONSOLE: *fileSize = 0; } return TCL_OK; } /*----------------------------------------------------------------------------- * TclXOSftruncate -- * System dependent interface to ftruncate functionality. * * Parameters: * o interp - Error messages are returned in the interpreter. * o channel - Channel to truncate. * o newSize - Size to truncate the file to. * o funcName - Command or other name to use in not available error. * Returns: * TCL_OK or TCL_ERROR. *----------------------------------------------------------------------------- */ int TclXOSftruncate (Tcl_Interp *interp, Tcl_Channel channel, off_t newSize, char *funcName) { HANDLE handle; int pos; tclXwinFileType type; handle = ChannelToHandle (channel, TCL_WRITABLE, &type); if (handle == INVALID_HANDLE_VALUE) { TclX_AppendObjResult (interp, "channel \"", Tcl_GetChannelName (channel), "\" was not open for write access", (char *) NULL); return TCL_ERROR; } if (type != TCLX_WIN_FILE) { TclX_AppendObjResult (interp, "truncation of \"", Tcl_GetChannelName (channel), "\" failed: can only truncate disk files", (char *) NULL); return TCL_ERROR; } pos = (int) Tcl_Tell (channel); if (SetFilePointer (handle, (LONG)newSize, NULL, FILE_BEGIN) == 0xFFFFFFFF) { TclWinConvertError (GetLastError ()); TclX_AppendObjResult (interp, "truncation of \"", Tcl_GetChannelName (channel), "\" failed: ", Tcl_PosixError (interp), (char *) NULL); return TCL_ERROR; } /* * FIX: we really ought to interpolate zeros when extending the file, * since SetEndOfFile does not promise to do this. */ if (!SetEndOfFile (handle)) { TclWinConvertError (GetLastError ()); TclX_AppendObjResult (interp, "truncation of \"", Tcl_GetChannelName (channel), "\" failed: ", Tcl_PosixError (interp), (char *) NULL); if (pos >= 0) { (void) SetFilePointer (handle, (LONG)pos, NULL, FILE_BEGIN); } return TCL_ERROR; } if (pos >= 0) { if (SetFilePointer (handle, (LONG)pos, NULL, FILE_BEGIN) == 0xFFFFFFFF) { TclWinConvertError (GetLastError ()); TclX_AppendObjResult (interp, "couldn't restore position after ", "truncating \"", Tcl_GetChannelName (channel), "\": ", Tcl_PosixError (interp), (char *) NULL); return TCL_ERROR; } } return TCL_OK; } /*----------------------------------------------------------------------------- * TclXOSfork -- * System dependent interface to fork functionality. Not supported on * windows. * * Parameters: * o interp - An error is returned in result. * o funcName - Command or other name to use in not available error. * Results: * TCL_OK or TCL_ERROR. *----------------------------------------------------------------------------- */ int TclXOSfork (Tcl_Interp *interp, Tcl_Obj *funcNameObj) { return TclXNotAvailableObjError (interp, funcNameObj); } /*----------------------------------------------------------------------------- * TclXOSexecl -- * System dependent interface to execl functionality. On windows, this is * the equivlant of a fork and an execl, so a process id is returned. * * Parameters: * o interp - A process id or errors are returned in result. * o path - Path to the program. * o argList - NULL terminated argument vector. * Results: * TCL_ERROR or does not return. *----------------------------------------------------------------------------- */ int TclXOSexecl (Tcl_Interp *interp, char *path, char **argList) { int pid; char numBuf [32]; pid = spawnvp (_P_NOWAIT , path, argList); if (pid == -1) { TclX_AppendObjResult (interp, "exec of \"", path, "\" failed: ", Tcl_PosixError (interp), (char *) NULL); return TCL_ERROR; } sprintf (numBuf, "%d", pid); Tcl_SetResult (interp, numBuf, TCL_VOLATILE); return TCL_OK; } /*----------------------------------------------------------------------------- * TclXOSInetAtoN -- * * Convert an internet address to an "struct in_addr" representation. * * Parameters: * o interp - If not NULL, an error message is return in the result. * If NULL, no error message is generated. * o strAddress - String address to convert. * o inAddress - Converted internet address is returned here. * Returns: * TCL_OK or TCL_ERROR. *----------------------------------------------------------------------------- */ int TclXOSInetAtoN (Tcl_Interp *interp, char *strAddress, struct in_addr *inAddress) { inAddress->s_addr = inet_addr (strAddress); if (inAddress->s_addr != INADDR_NONE) return TCL_OK; if (interp != NULL) { TclX_AppendObjResult (interp, "malformed address: \"", strAddress, "\"", (char *) NULL); } return TCL_ERROR; } /*----------------------------------------------------------------------------- * TclXOSgetpeername -- * System dependent interface to getpeername functionality. * * Parameters: * o interp - Errors are returned in result. * o channel - Channel associated with the socket. * o sockaddr - Pointer to sockaddr structure. * o sockaddrSize - Size of the sockaddr struct. * Results: * TCL_OK or TCL_ERROR, sets a posix error. *----------------------------------------------------------------------------- */ int TclXOSgetpeername (Tcl_Interp *interp, Tcl_Channel channel, void *sockaddr, int sockaddrSize) { SOCKET sock; sock = ChannelToSocket (interp, channel); if (sock == INVALID_SOCKET) return TCL_ERROR; if (getpeername (sock, (struct sockaddr *) sockaddr, &sockaddrSize) < 0) { TclX_AppendObjResult (interp, Tcl_GetChannelName (channel), ": ", Tcl_PosixError (interp), (char *) NULL); return TCL_ERROR; } return TCL_OK; } /*----------------------------------------------------------------------------- * TclXOSgetsockname -- * System dependent interface to getsockname functionality. * * Parameters: * o interp - Errors are returned in result. * o channel - Channel associated with the socket. * o sockaddr - Pointer to sockaddr structure. * o sockaddrSize - Size of the sockaddr struct. * Results: * TCL_OK or TCL_ERROR, sets a posix error. *----------------------------------------------------------------------------- */ int TclXOSgetsockname (Tcl_Interp *interp, Tcl_Channel channel, void *sockaddr, int sockaddrSize) { SOCKET sock; sock = ChannelToSocket (interp, channel); if (sock == INVALID_SOCKET) return TCL_ERROR; if (getsockname (sock, (struct sockaddr *) sockaddr, &sockaddrSize) < 0) { TclX_AppendObjResult (interp, Tcl_GetChannelName (channel), ": ", Tcl_PosixError (interp), (char *) NULL); return TCL_ERROR; } return TCL_OK; } /*----------------------------------------------------------------------------- * TclXOSgetsockopt -- * Get the value of a integer socket option. * * Parameters: * o interp - Errors are returned in the result. * o channel - Channel associated with the socket. * o option - Socket option to get. * o valuePtr - Integer value is returned here. * Returns: * TCL_OK or TCL_ERROR. *----------------------------------------------------------------------------- */ int TclXOSgetsockopt (interp, channel, option, valuePtr) Tcl_Interp *interp; Tcl_Channel channel; int option; int *valuePtr; { int valueLen = sizeof (*valuePtr); SOCKET sock; sock = ChannelToSocket (interp, channel); if (sock == INVALID_SOCKET) return TCL_ERROR; if (getsockopt (sock, SOL_SOCKET, option, (void*) valuePtr, &valueLen) != 0) { TclX_AppendObjResult (interp, Tcl_GetChannelName (channel), ": ", Tcl_PosixError (interp), (char *) NULL); return TCL_ERROR; } return TCL_OK; } /*----------------------------------------------------------------------------- * TclXOSsetsockopt -- * Set the value of a integer socket option. * * Parameters: * o interp - Errors are returned in the result. * o channel - Channel associated with the socket. * o option - Socket option to get. * o value - Valid integer value for the option. * Returns: * TCL_OK or TCL_ERROR. *----------------------------------------------------------------------------- */ int TclXOSsetsockopt (interp, channel, option, value) Tcl_Interp *interp; Tcl_Channel channel; int option; int value; { int valueLen = sizeof (value); SOCKET sock; sock = ChannelToSocket (interp, channel); if (sock == INVALID_SOCKET) return TCL_ERROR; if (setsockopt (sock, SOL_SOCKET, option, (void*) &value, valueLen) != 0) { TclX_AppendObjResult (interp, Tcl_GetChannelName (channel), ": ", Tcl_PosixError (interp), (char *) NULL); return TCL_ERROR; } return TCL_OK; } /*----------------------------------------------------------------------------- * TclXOSchmod -- * System dependent interface to chmod functionality. * * Parameters: * o interp - Errors returned in result. * o fileName - Name of to set the mode on. * o mode - New, unix style file access mode. * Results: * TCL_OK or TCL_ERROR. *----------------------------------------------------------------------------- */ int TclXOSchmod (interp, fileName, mode) Tcl_Interp *interp; char *fileName; int mode; { #if 0 /*FIX:*/ if (chmod (fileName, (unsigned short) mode) < 0) { TclX_AppendObjResult (interp, "chmod failed on \"", fileName, "\": ", Tcl_PosixError (interp), (char *) NULL); return TCL_ERROR; } return TCL_OK; #else TclX_AppendObjResult (interp, "chmod is not available on this system", (char *) NULL); return TCL_ERROR; #endif } /*----------------------------------------------------------------------------- * TclXOSfchmod -- * System dependent interface to fchmod functionality. * * Parameters: * o interp - Errors returned in result. * o channel - Channel to set the mode on. * o mode - New, unix style file access mode. * o funcName - Command or other string to use in not available error. * Results: * TCL_OK or TCL_ERROR. *----------------------------------------------------------------------------- */ int TclXOSfchmod (interp, channel, mode, funcName) Tcl_Interp *interp; Tcl_Channel channel; int mode; char *funcName; { #if 0 FIX: if (fchmod (ChannelToFnum (channel, 0), (unsigned short) mode) < 0) { TclX_AppendObjResult (interp, Tcl_PosixError (interp), (char *) NULL); return TCL_ERROR; } #else TclX_AppendObjResult (interp, funcName, " is not available on this system", (char *) NULL); return TCL_ERROR; #endif } /*----------------------------------------------------------------------------- * TclXOSChangeOwnGrp -- * Change the owner and/or group of a file by file name. * * Parameters: * o interp - Pointer to the current interpreter, error messages will be * returned in the result. * o options - Option flags are: * o TCLX_CHOWN - Change file's owner. * o TCLX_CHGRP - Change file's group. * o ownerStr - String containing owner name or id. NULL if TCLX_CHOWN * not specified. * o groupStr - String containing owner name or id. NULL if TCLX_CHOWN * not specified. If NULL and TCLX_CHOWN is specified, the user's group * is used. * o files - NULL terminated list of file names. * o funcName - Command or other name to use in not available error. * Returns: * TCL_OK or TCL_ERROR. *----------------------------------------------------------------------------- */ int TclXOSChangeOwnGrpObj (interp, options, ownerStr, groupStr, files, funcName) Tcl_Interp *interp; unsigned options; char *ownerStr; char *groupStr; Tcl_Obj *files; char *funcName; { return TclXNotAvailableError (interp, funcName); } /*----------------------------------------------------------------------------- * TclXOSFChangeOwnGrp -- * Change the owner and/or group of a file by open channel. * * Parameters: * o interp - Pointer to the current interpreter, error messages will be * returned in the result. * o options - Option flags are: * o TCLX_CHOWN - Change file's owner. * o TCLX_CHGRP - Change file's group. * o ownerStr - String containing owner name or id. NULL if TCLX_CHOWN * not specified. * o groupStr - String containing owner name or id. NULL if TCLX_CHOWN * not specified. If NULL and TCLX_CHOWN is specified, the user's group * is used. * o channelIds - NULL terminated list of channel ids. * o funcName - Command or other name to use in not available error. * Returns: * TCL_OK or TCL_ERROR. *----------------------------------------------------------------------------- */ int TclXOSFChangeOwnGrpObj (interp, options, ownerStr, groupStr, channelIds, funcName) Tcl_Interp *interp; unsigned options; char *ownerStr; char *groupStr; Tcl_Obj *channelIds; char *funcName; { return TclXNotAvailableError (interp, funcName); } /*----------------------------------------------------------------------------- * TclXOSGetSelectFnum -- * Convert a channel its read and write file numbers for use in select. * * Parameters: * o interp - Pointer to the current interpreter, error messages will be * returned in the result. * o channel - Channel to get the numbers for. * o direction - TCL_READABLE or TCL_WRITABLE. * o fnumPtr - The file number for the direction is returned here. * Returns: * TCL_OK or TCL_ERROR. *----------------------------------------------------------------------------- */ int TclXOSGetSelectFnum (Tcl_Interp *interp, Tcl_Channel channel, int direction, int *fnumPtr) { tclXwinFileType type; HANDLE handle = ChannelToHandle (channel, direction, &type); if (handle == INVALID_HANDLE_VALUE) { TclX_AppendObjResult (interp, "channel \"", Tcl_GetChannelName (channel), "\" was not open for requested access", (char *) NULL); return TCL_ERROR; } if (type != TCLX_WIN_SOCKET) { TclX_AppendObjResult (interp, "channel \"", Tcl_GetChannelName (channel), "\" is not a socket; select only works on ", "sockets on Windows", (char *) NULL); return TCL_ERROR; } *fnumPtr = (int) handle; return TCL_OK; } /*----------------------------------------------------------------------------- * TclXOSHaveFlock -- * System dependent interface to determine if file locking is available. * Returns: * TRUE if file locking is available, FALSE if it is not. *----------------------------------------------------------------------------- */ int TclXOSHaveFlock () { OVERLAPPED start; start.Internal = 0; start.InternalHigh = 0; start.Offset = 0; start.OffsetHigh = 0; start.hEvent = 0; if (!LockFileEx (NULL, 0, 0, 0, 0, &start)) { if (GetLastError () == ERROR_CALL_NOT_IMPLEMENTED) return FALSE; } return TRUE; } /*----------------------------------------------------------------------------- * LockUnlockSetup -- * * Do common setup work for locking or unlocking a file. * * Parameters: * o interp - Errors are return in the result. * o lockInfoPtr - Lock specification. * o startPtr - Start of area to lock is returned in struct. * o lengthLowPtr - Low-order 32 bits of length of the file to lock. * o lengthHighPtr - High-order 32 bits of length of the file to lock. Files * of length greater than 32 bits are not support. This is only to allow * for locking the entier range of the file * o whichMsg - Either "lock" or "unlock", for error messages. * Returns: * The file handle or NULL if an error occurs. *----------------------------------------------------------------------------- */ static HANDLE LockUnlockSetup (Tcl_Interp *interp, TclX_FlockInfo *lockInfoPtr, LPOVERLAPPED startPtr, LPDWORD lengthLowPtr, LPDWORD lengthHighPtr, char *whichMsg) { HANDLE handle; tclXwinFileType type; /* * Get the handle and validate that this is something we can lock. */ handle = ChannelToHandle (lockInfoPtr->channel, 0, &type); if (handle == INVALID_HANDLE_VALUE) { TclX_AppendObjResult (interp, "channel \"", Tcl_GetChannelName (lockInfoPtr->channel), "\" has no device handle", (char *) NULL); return handle; } switch (type) { case TCLX_WIN_PIPE: TclX_AppendObjResult (interp, "can't lock a pipe line under MS Windows", (char *) NULL); return INVALID_HANDLE_VALUE; case TCLX_WIN_FILE: break; case TCLX_WIN_SOCKET: TclX_AppendObjResult (interp, "can't lock a socket under windows", (char *) NULL); return INVALID_HANDLE_VALUE; case TCLX_WIN_CONSOLE: break; /* FIX: Is this legal?? */ default: panic ("unknown win channel type %d\n", type); } /* * Calculate actual offset of the start. */ switch (lockInfoPtr->whence) { case 0: /* start */ startPtr->Offset = lockInfoPtr->start; break; case 1: /* current */ startPtr->Offset = SetFilePointer (handle, 0, NULL, FILE_CURRENT); if (startPtr->Offset == 0xFFFFFFFF) goto winError; startPtr->Offset += lockInfoPtr->start; break; case 2: /* end */ startPtr->Offset = GetFileSize (handle, NULL); if (startPtr->Offset < 0) goto winError; startPtr->Offset += lockInfoPtr->start; break; } startPtr->Internal = 0; startPtr->InternalHigh = 0; startPtr->OffsetHigh = 0; startPtr->hEvent = 0; /* * Determine length of lock. If zero, the remained of the file is locked * out its maximum length. */ *lengthHighPtr = 0; if (lockInfoPtr->len == 0) { *lengthHighPtr = 0x7FFFFFFF; *lengthLowPtr = 0xFFFFFFFF; } else { *lengthLowPtr = lockInfoPtr->len; } return handle; winError: TclWinConvertError (GetLastError ()); lockInfoPtr->gotLock = FALSE; TclX_AppendObjResult (interp, whichMsg, " of \"", Tcl_GetChannelName (lockInfoPtr->channel), "\" failed: ", Tcl_PosixError (interp), (char *) NULL); return INVALID_HANDLE_VALUE; } /*----------------------------------------------------------------------------- * TclXOSFlock -- * System dependent interface to locking a file. * * Parameters: * o interp - Pointer to the current interpreter, error messages will be * returned in the result. * o lockInfoPtr - Lock specification, gotLock will be initialized. * Returns: * TCL_OK or TCL_ERROR. *----------------------------------------------------------------------------- */ int TclXOSFlock (interp, lockInfoPtr) Tcl_Interp *interp; TclX_FlockInfo *lockInfoPtr; { HANDLE handle; DWORD flags, lengthHigh, lengthLow; OVERLAPPED start; handle = LockUnlockSetup (interp, lockInfoPtr, &start, &lengthLow, &lengthHigh, "lock"); if (handle == INVALID_HANDLE_VALUE) return TCL_ERROR; flags = 0; if (lockInfoPtr->access == TCL_WRITABLE) flags |= LOCKFILE_EXCLUSIVE_LOCK; if (!lockInfoPtr->block) flags |= LOCKFILE_FAIL_IMMEDIATELY; if (!LockFileEx (handle, flags, 0, lengthLow, lengthHigh, &start)) { if (GetLastError () == ERROR_LOCK_VIOLATION) { lockInfoPtr->gotLock = FALSE; return TCL_OK; } goto winError; } lockInfoPtr->gotLock = TRUE; return TCL_OK; winError: if (GetLastError () == ERROR_CALL_NOT_IMPLEMENTED) { TclX_AppendObjResult (interp, "file locking is not yet available on ", "Windows 3.1 and 95", (char *) NULL); } else { TclWinConvertError (GetLastError ()); TclX_AppendObjResult (interp, "lock of \"", Tcl_GetChannelName (lockInfoPtr->channel), "\" failed: ", Tcl_PosixError (interp), (char *) NULL); } lockInfoPtr->gotLock = FALSE; return TCL_ERROR; } /*----------------------------------------------------------------------------- * TclXOSFunlock -- * System dependent interface to unlocking a file. * * Parameters: * o interp - Pointer to the current interpreter, error messages will be * returned in the result. * o lockInfoPtr - Lock specification. * Returns: * TCL_OK or TCL_ERROR. *----------------------------------------------------------------------------- */ int TclXOSFunlock (interp, lockInfoPtr) Tcl_Interp *interp; TclX_FlockInfo *lockInfoPtr; { HANDLE handle; DWORD lengthHigh, lengthLow; OVERLAPPED start; handle = LockUnlockSetup (interp, lockInfoPtr, &start, &lengthLow, &lengthHigh, "unlock"); if (handle == INVALID_HANDLE_VALUE) return TCL_ERROR; if (!UnlockFileEx (handle, 0, lengthLow, lengthHigh, &start)) { goto winError; } return TCL_OK; winError: if (GetLastError () == ERROR_CALL_NOT_IMPLEMENTED) { TclX_AppendObjResult (interp, "file locking is not yet available on ", "Windows 3.1 and 95", (char *) NULL); } else { TclWinConvertError (GetLastError ()); TclX_AppendObjResult (interp, "unlock of \"", Tcl_GetChannelName (lockInfoPtr->channel), "\" failed: ", Tcl_PosixError (interp), (char *) NULL); } return TCL_ERROR; } /*----------------------------------------------------------------------------- * TclXOSGetAppend -- * System dependent interface determine if a channel is in force append mode. * * Parameters: * o interp - Pointer to the current interpreter, error messages will be * returned in the result. * o channel - Channel to get mode for. The write file is used. * o valuePtr - TRUE is returned if in append mode, FALSE if not. * Returns: * TCL_OK or TCL_ERROR. *----------------------------------------------------------------------------- */ int TclXOSGetAppend (interp, channel, valuePtr) Tcl_Interp *interp; Tcl_Channel channel; int *valuePtr; { return TclXNotAvailableError (interp, "append mode"); } /*----------------------------------------------------------------------------- * TclXOSSetAppend -- * System dependent interface set force append mode on a channel. * * Parameters: * o interp - Pointer to the current interpreter, error messages will be * returned in the result. * o channel - Channel to get mode for. The write file is used. * o value - TRUE to enable, FALSE to disable. * Returns: * TCL_OK or TCL_ERROR. *----------------------------------------------------------------------------- */ int TclXOSSetAppend (interp, channel, value) Tcl_Interp *interp; Tcl_Channel channel; int value; { return TclXNotAvailableError (interp, "append mode"); } /*----------------------------------------------------------------------------- * TclXOSGetCloseOnExec -- * System dependent interface determine if a channel has close-on-exec set. * * Parameters: * o interp - Pointer to the current interpreter, error messages will be * returned in the result. * o channel - Channel to get mode for. The write file is used. * o valuePtr - TRUE is close-on-exec, FALSE if not. * Returns: * TCL_OK or TCL_ERROR. *----------------------------------------------------------------------------- */ int TclXOSGetCloseOnExec (interp, channel, valuePtr) Tcl_Interp *interp; Tcl_Channel channel; int *valuePtr; { HANDLE handle; tclXwinFileType type; DWORD flags; handle = ChannelToHandle (channel, 0, &type); if (handle == INVALID_HANDLE_VALUE) { TclX_AppendObjResult (interp, "channel \"", Tcl_GetChannelName (channel), "\" has no device handle", (char *) NULL); return TCL_ERROR; } /* * The following works on Windows NT, but not on Windows 95. */ if (!GetHandleInformation (handle, &flags)) { TclWinConvertError (GetLastError ()); TclX_AppendObjResult (interp, "getting close-on-exec for \"", Tcl_GetChannelName (channel), "\" failed: ", Tcl_PosixError (interp), (char *) NULL); return TCL_ERROR; } /* * N.B. The value of the CLOEXEC flag is the inverse of HANDLE_FLAG_INHERIT. */ *valuePtr = (flags & HANDLE_FLAG_INHERIT) ? 0 : 1; return TCL_OK; } /*----------------------------------------------------------------------------- * TclXOSSetCloseOnExec -- * System dependent interface set close-on-exec on a channel. * * Parameters: * o interp - Pointer to the current interpreter, error messages will be * returned in the result. * o channel - Channel to get mode for. The write file is used. * o value - TRUE to enable, FALSE to disable. * Returns: * TCL_OK or TCL_ERROR. *----------------------------------------------------------------------------- */ int TclXOSSetCloseOnExec (interp, channel, value) Tcl_Interp *interp; Tcl_Channel channel; int value; { HANDLE handle; tclXwinFileType type; handle = ChannelToHandle (channel, 0, &type); if (handle == INVALID_HANDLE_VALUE) { TclX_AppendObjResult (interp, "channel \"", Tcl_GetChannelName (channel), "\" has no device handle", (char *) NULL); return TCL_ERROR; } /* * The following works on Windows NT, but not on Windows 95. * N.B. The value of the CLOEXEC flag is the inverse of HANDLE_FLAG_INHERIT. */ if (!SetHandleInformation (handle, HANDLE_FLAG_INHERIT, value ? 0 : HANDLE_FLAG_INHERIT)) { TclWinConvertError (GetLastError ()); TclX_AppendObjResult (interp, "setting close-on-exec for \"", Tcl_GetChannelName (channel), "\" failed: ", Tcl_PosixError (interp), (char *) NULL); return TCL_ERROR; } return TCL_OK; } tclx8.4-8.4.1.orig/win/tclXAppInit.c0000644000000000000000000000541112046313170013713 0ustar /* * tclXAppInit.c -- * * Provides a default version of the Tcl_AppInit procedure for use with * applications built with Extended Tcl on Windows 95/NT systems. *----------------------------------------------------------------------------- * Copyright 1991-1999 Karl Lehenbauer and Mark Diekhans. * * Permission to use, copy, modify, and distribute this software and its * documentation for any purpose and without fee is hereby granted, provided * that the above copyright notice appear in all copies. Karl Lehenbauer and * Mark Diekhans make no representations about the suitability of this * software for any purpose. It is provided "as is" without express or * implied warranty. *----------------------------------------------------------------------------- * $Id: tclXAppInit.c,v 1.1 2001/10/24 23:31:50 hobbs Exp $ *----------------------------------------------------------------------------- */ /* * As a shell (i.e., the main program) we cannot be using the stubs table. */ #ifdef USE_TCL_STUBS #undef USE_TCL_STUBS #endif #include "tclExtend.h" /*----------------------------------------------------------------------------- * TclX_AppInit -- * * This procedure performs application-specific initialization. Most * applications, especially those that incorporate additional packages, will * have their own version of this procedure. * * Results: * Returns a standard Tcl completion code, and leaves an error message in * interp result if an error occurs. *----------------------------------------------------------------------------- */ int TclX_AppInit (Tcl_Interp *interp) { if (Tcl_Init (interp) == TCL_ERROR) { return TCL_ERROR; } if (Tclx_Init (interp) == TCL_ERROR) { return TCL_ERROR; } Tcl_StaticPackage (interp, "Tclx", Tclx_Init, Tclx_SafeInit); /* * Call Tcl_CreateCommand for application-specific commands, if * they weren't already created by the init procedures called above. */ /* * Specify a user-specific startup file to invoke if the application * is run interactively. Typically the startup file is "~/.apprc" * where "app" is the name of the application. If this line is deleted * then no user-specific startup file will be run under any conditions. */ Tcl_SetVar(interp, "tcl_rcFileName", "~/.tclrc", TCL_GLOBAL_ONLY); return TCL_OK; } /*----------------------------------------------------------------------------- * main -- * * This is the main program for the application. *----------------------------------------------------------------------------- */ int main (int argc, char **argv) { TclX_MainEx (argc, argv, TclX_AppInit, Tcl_CreateInterp()); return 0; /* Needed only to prevent compiler warning. */ } tclx8.4-8.4.1.orig/win/cattcl.c0000644000000000000000000000735212046313170012774 0ustar /* * cattcl.c -- * A crude version of cat used in the build to concatenate Tcl source * files into a library. *----------------------------------------------------------------------------- * Copyright 1996-1999 Karl Lehenbauer and Mark Diekhans. * * Permission to use, copy, modify, and distribute this software and its * documentation for any purpose and without fee is hereby granted, provided * that the above copyright notice appear in all copies. Karl Lehenbauer and * Mark Diekhans make no representations about the suitability of this * software for any purpose. It is provided "as is" without express or * implied warranty. *----------------------------------------------------------------------------- * $Id: cattcl.c,v 1.1 2001/10/24 23:31:50 hobbs Exp $ *----------------------------------------------------------------------------- */ #include #include /*----------------------------------------------------------------------------- * TclX_SplitWinCmdLine -- * Parse the window command line into arguments. * * Parameters: * o argcPtr (O) - Count of arguments is returned here. * o argvPtr (O) - Argument vector is returned here. * Notes: * This code taken from the Tcl file tclAppInit.c: Copyright (c) 1996 by * Sun Microsystems, Inc. *----------------------------------------------------------------------------- */ void TclX_SplitWinCmdLine (argcPtr, argvPtr) int *argcPtr; char ***argvPtr; { char *args = GetCommandLine (); char **argvlist, *p; int size, i; /* * Precompute an overly pessimistic guess at the number of arguments * in the command line by counting non-space spans. */ for (size = 2, p = args; *p != '\0'; p++) { if (isspace (*p)) { size++; while (isspace (*p)) { p++; } if (*p == '\0') { break; } } } argvlist = (char **) malloc ((unsigned) (size * sizeof (char *))); *argvPtr = argvlist; /* * Parse the Windows command line string. If an argument begins with a * double quote, then spaces are considered part of the argument until the * next double quote. The argument terminates at the second quote. Note * that this is different from the usual Unix semantics. */ for (i = 0, p = args; *p != '\0'; i++) { while (isspace (*p)) { p++; } if (*p == '\0') { break; } if (*p == '"') { p++; (*argvPtr) [i] = p; while ((*p != '\0') && (*p != '"')) { p++; } } else { (*argvPtr) [i] = p; while (*p != '\0' && !isspace(*p)) { p++; } } if (*p != '\0') { *p = '\0'; p++; } } (*argvPtr) [i] = NULL; *argcPtr = i; } /* * Concatenate a bunch of files. */ int main (int argc, char **argv) { FILE *fh; int idx, c; TclX_SplitWinCmdLine (&argc, &argv); for (idx = 1; idx < argc; idx++) { fh = fopen (argv [idx], "r"); if (fh == NULL) { fprintf (stderr, "error opening \"%s\": %s\n", argv [idx], strerror (errno)); exit (1); } while ((c = fgetc (fh)) != EOF) { if (fputc (c, stdout) == EOF) { fprintf (stderr, "error writing stdout: %s\n", strerror (errno)); exit (1); } } if (ferror (fh)) { fprintf (stderr, "error reading \"%s\": %s\n", argv [idx], strerror (errno)); exit (1); } fclose (fh); } return 0; } tclx8.4-8.4.1.orig/unix/0000755000000000000000000000000012046525461011545 5ustar tclx8.4-8.4.1.orig/unix/INSTALL0000644000000000000000000001362612046313167012604 0ustar INSTALLATION INSTRUCTIONS FOR EXTENDED TCL ON UNIX AND UNIX-LIKE SYSTEMS ------------------------------------------------------------------------ $Id: INSTALL,v 8.19 2005/11/20 19:58:27 hobbs Exp $ See the toplevel README for updated TEA-based install instructions. This file remains for porting notes. COMPATIBILITY ============= This version is compatible Tcl 8.2.0+ PORTING NOTES ============= General Porting Notes: o Flock test hanging: Running the flock tests on a tmpfs filesystem will cause flock failures on some systems. o Other flock tests hanging: Problems have been encountered on some Sun systems with the flock tests. This might occur on other systems as well. These are probably due to an incorrectly configured NFS lockd. The tests have been modified to try and report problems rather than hang. It might hang anyway, in this case, rename tests/flock.test to tests/flock.bad to prevent them from being run. If anyone can give any clues into what is going on, we would love to detect this. SVR3 systems (14 character file name limit): o All critical files in TclX are 14 characters or less. A few help files are longer that 14 characters. If these can be extracted with name truncation, they can still be referenced in the help system by the truncated name. If they can't be extracted, then they can be regenerated with truncated names by doing a "make buildhelp". DEC Ultrix: o Setting O_APPEND via the fcntl FSETFL system call returns an EOPNOTSUPP (Operation not supported) error. This causes failures of fcntl tests 2.4 and 2.5. This is an Ultrix bug as far as we can tell. o The fstat system call does does not return updated modification times on an open file. This causes fstat test 3.1 to fail. This is an Ultrix bug. o Several tests fail when Tcl is run on an NFS mounted file system. o Problems with flock tests have been reported on some Ultrix systems. See `General Porting Notes' section above. DEC Alpha: o message-cat-1.3 test fails due to broken catopen. This is should not affect actual use of this command. o On OSF/1 V2.0 Rev 240 it has been noted that strtod segmentation faults when the first character of a string has the high order bit set. This breaks string expressions and eight bit characters. SUNOS: o See note on flock tests hanging under the "general" section. SOLARIS: o glob & library test failures observed on SunOS 5.3. Doing a "glob *" in either the tclX shell or tclsh produces a mangled listing of the directory. This is caused by a mismatch between the the dirent.h include file and C library that is being used. We have been told that this can be fixed either by making sure /usr/ucb is not in your path or by compiling with the "ucbcc" command. If you chose to use ucbcc, remember to set CC=ucbcc environment variable, make clean, and reconfigure before going a "make CC=ucbcc". Using gcc is another solution. o message-cat-1.3 test fails due to broken catopen. This is should not affect actual use of this command. o compat/server tests 8.2.8 and 8.2.22 fail on Solaris 2.4 and maybe earlier. This appears to be a bug in the Solaris kernal related to dup-ing sockets. The problem does not occur in Solaris 2.5.1. SCO: o SCO Unix systems have a "ranlib" command that is used for Xenix cross- development. Pre-ODT 3.0 development systems, the command returns an error if used on COFF files. Many developers rename the command to "xranlib" if they are not doing cross development. Later versions of the command return a warning if used on COFF binaries. SGI: o There appears to be a compiler bug with some SGI compilers. If you see core dumps during the tests, recompile both Tcl and TclX without -O (make CFLAGS=). This was seen on IRIX 4.0.5. o Systems upgraded to IRIX 5.2 may have old versions of libsocket.a and libnsl.a left on the system. The configure will pick these up and attempt to use them. This will prevent wishx from connecting to the display. Either remove the files from the system or edit the makefiles to remove the use of "-lsocket -lnsl". o The fstat system call does does not return updated modification times on an open NFS accessed file. This causes fstat test 3.1 to fail. This is an IRIX bug. BSDI: o The BSDI 1.0 make is broken. It does not correctly handle the setting of ${MAKEFLAGS} and quits on an error when an empty make flags set is passed to the next level of make. GNU make is advised instead. Use the following make command to work around the problem: make -k MAKEFLAGS=k o BSDI 1.1 nice system call does not return an error on attempts to increase priority for non-root users. This causes nice test 1.7 to fail. o Also seee the 386BSD/BSDI section below. 386BSD/NetBSD: o Expect round off errors in floating point math tests. o Expect errors in floating point math error handling tests. o Expect errors in format command tests. o The installation of the manual pages fails because make can't handle passing a empty string as an argument to a program (it deletes the string). Try GNU make. o NetBSD 1.0 declares catclose as returning void rather than int. This is checked for in configure but still causes the message-cat-2.4 test to fail. CONVEX: o Set both NOBUF and NONBLOCK on a pipe will result in read returning the the error "Errno is zero". LINUX: o If shell scripts run in make file exit with exit code 127, a new version of Bash is needed. o Received error: ld: Output file requires shared library `libc.so.4' gcc: Internal compiler error: program ld got fatal signal 6: Recompile without -g. CRAY: o catgets does not return the default string, causing failure of some msgcat tests. tclx8.4-8.4.1.orig/unix/tools/0000755000000000000000000000000012046525461012705 5ustar tclx8.4-8.4.1.orig/unix/tools/buildutil.tcl0000644000000000000000000001055512046313167015412 0ustar # # buildutil.tcl -- # # Utility procedures used by the build and install tools. #------------------------------------------------------------------------------ # Copyright 1992-1999 Karl Lehenbauer and Mark Diekhans. # # Permission to use, copy, modify, and distribute this software and its # documentation for any purpose and without fee is hereby granted, provided # that the above copyright notice appear in all copies. Karl Lehenbauer and # Mark Diekhans make no representations about the suitability of this # software for any purpose. It is provided "as is" without express or # implied warranty. #------------------------------------------------------------------------------ # $Id: buildutil.tcl,v 8.8 2000/07/14 18:08:03 welch Exp $ #------------------------------------------------------------------------------ # #------------------------------------------------------------------------------ # MakeAbs -- # Base a file name absolute. #------------------------------------------------------------------------------ proc MakeAbs fname { switch [file pathtype $fname] { absolute { return $fname } relative { return [file join [pwd] $fname] } volumerelative { return [eval file join [linsert [file split $fname] 1 [pwd]]] } } } #------------------------------------------------------------------------------ # CopyFile -- # # Copy the specified file and change the ownership. If target is a directory, # then the file is copied to it, otherwise target is a new file name. # If the source file was owner-executable, the all-executable is set on the # created file. #------------------------------------------------------------------------------ proc CopyFile {sourceFile target} { global tcl_platform if {[lsearch {.orig .diff .rej} [file extension $sourceFile]] >= 0} { return } if {[file isdirectory $target]} { set targetFile [file join $target [file tail $sourceFile]] } else { set targetFile $target } file delete -force $targetFile set sourceFH [open $sourceFile r] set targetFH [open $targetFile w] fconfigure $sourceFH -translation binary -eofchar {} fconfigure $targetFH -translation binary -eofchar {} fcopy $sourceFH $targetFH close $sourceFH close $targetFH # Fixup the mode. # FIX: chmod not ported to windows yet. if ![cequal $tcl_platform(platform) windows] { file stat $sourceFile sourceStat if {$sourceStat(mode) & 0100} { chmod a+rx $targetFile } else { chmod a+r $targetFile } } } #------------------------------------------------------------------------------ # CopySubDir -- # # Recursively copy part of a directory tree, changing ownership and # permissions. This is a utility routine that actually does the copying. #------------------------------------------------------------------------------ proc CopySubDir {sourceDir destDir} { foreach sourceFile [readdir $sourceDir] { set sourcePath [file join $sourceDir $sourceFile] if [file isdirectory $sourcePath] { if [cequal [file tail $sourceFile] "CVS"] { continue } set destFile [file join $destDir $sourceFile] file mkdir $destFile CopySubDir $sourcePath $destFile } else { CopyFile $sourcePath $destDir } } } #------------------------------------------------------------------------------ # CopyDir -- # # Recurisvely copy a directory tree. #------------------------------------------------------------------------------ proc CopyDir {sourceDir destDir} { set cwd [pwd] if ![file exists $sourceDir] { error "\"$sourceDir\" does not exist" } if ![file isdirectory $sourceDir] { error "\"$sourceDir\" isn't a directory" } if [cequal [file tail $sourceDir] "CVS"] { return } # Dirs must be absolutes paths, as we are going to change directories. set sourceDir [MakeAbs $sourceDir] set destDir [MakeAbs $destDir] file mkdir $destDir if ![file isdirectory $destDir] { error "\"$destDir\" isn't a directory" } cd $sourceDir set status [catch {CopySubDir . $destDir} msg] cd $cwd if {$status != 0} { global errorInfo errorCode error $msg $errorInfo $errorCode } } tclx8.4-8.4.1.orig/unix/tools/Makefile.in0000644000000000000000000000422312046313167014751 0ustar # # unix/tools/Makefile.in -- # # Makefile for building tools used during build and install process. Nothing # here is actually installed on the system. #------------------------------------------------------------------------------ # Copyright 1992-1999 Karl Lehenbauer and Mark Diekhans. # # Permission to use, copy, modify, and distribute this software and its # documentation for any purpose and without fee is hereby granted, provided # that the above copyright notice appear in all copies. Karl Lehenbauer and # Mark Diekhans make no representations about the suitability of this # software for any purpose. It is provided "as is" without express or # implied warranty. #------------------------------------------------------------------------------ # $Id: Makefile.in,v 8.4 1999/07/07 02:47:15 wart Exp $ #------------------------------------------------------------------------------ # #------------------------------------------------------------------------------ # Common and user-editable defines. # srcdir = @srcdir@ @MAKEINCLUDE@ @MAKEQUOTE@@bldbasedir@/unix/Common.mk@MAKEQUOTE@ #------------------------------------------------------------------------------ all: instcopy bldmanhelp cpmanpages cphelpdir instcopy: ${srcdir}/instcopy.tcl ${srcdir}/buildutil.tcl rm -f instcopy cat ${srcdir}/buildutil.tcl ${srcdir}/instcopy.tcl >instcopy bldmanhelp: ${srcdir}/bldmanhelp.tcl rm -f bldmanhelp cp ${srcdir}/bldmanhelp.tcl bldmanhelp cpmanpages: ${srcdir}/cpmanpages.tcl ${srcdir}/buildutil.tcl rm -f cpmanpages cat ${srcdir}/buildutil.tcl ${srcdir}/cpmanpages.tcl >cpmanpages cphelpdir: ${srcdir}/cphelpdir.sh rm -f cphelpdir echo ":" >cphelpdir echo "TOOLS=${bldbasedir}/tools" >>cphelpdir cat ${srcdir}/cphelpdir.sh >>cphelpdir chmod a+x cphelpdir #------------------------------------------------------------------------------ clean: -rm -f instcopy bldmanhelp cpmanpages cphelpdir #------------------------------------------------------------------------------ # Restore to the distributed state. distclean: clean rm -f Makefile # Disable Sun's parallel make, it doesn't get the dependencies right. .NO_PARALLEL: tclx8.4-8.4.1.orig/unix/tools/tclmanpages0000644000000000000000000001107612046313167015131 0ustar # # tclmanpages -- # # Manual info file to be sources by bldmanhelp.tcl that returns a table # describing the Tcl manual to build the help files from. #------------------------------------------------------------------------------ # Copyright 1992-1999 Karl Lehenbauer and Mark Diekhans. # # Permission to use, copy, modify, and distribute this software and its # documentation for any purpose and without fee is hereby granted, provided # that the above copyright notice appear in all copies. Karl Lehenbauer and # Mark Diekhans make no representations about the suitability of this # software for any purpose. It is provided "as is" without express or # implied warranty. #------------------------------------------------------------------------------ # $Id: tclmanpages,v 8.9 2004/12/01 23:30:17 hobbs Exp $ #------------------------------------------------------------------------------ # set docs { {Tcl.n tcl/intro/syntax} {append.n tcl/strings/append} {after.n tcl/events/after} {array.n tcl/variables/array} {bgerror.n tcl/events/background-error} {binary.n tcl/strings/binary} {break.n tcl/control/break} {case.n tcl/control/case} {catch.n tcl/control/catch} {cd.n tcl/status/cd} {clock.n tcl/time/clock} {close.n tcl/files/close} {concat.n tcl/lists/concat} {continue.n tcl/control/continue} {dde.n tcl/control/dde} {encoding.n tcl/intl/encoding} {eof.n tcl/files/eof} {error.n tcl/control/error} {eval.n tcl/control/eval} {exec.n tcl/processes/exec} {exit.n tcl/control/exit} {expr.n tcl/math/expr} {fblocked.n tcl/files/fblocked} {fconfigure.n tcl/files/fconfigure} {fcopy.n tcl/files/fcopy} {file.n tcl/files/file} {fileevent.n tcl/events/fileevent} {filename.n tcl/files/filename} {flush.n tcl/files/flush} {for.n tcl/control/for} {foreach.n tcl/control/foreach} {format.n tcl/strings/format} {gets.n tcl/files/gets} {glob.n tcl/files/glob} {global.n tcl/variables/global} {history.n tcl/status/history} {http.n tcl/sockets/http} {if.n tcl/control/if} {incr.n tcl/math/incr} {info.n tcl/status/info} {interp.n tcl/control/interp} {join.n tcl/lists/join} {lappend.n tcl/lists/lappend} {library.n tcl/libraries/library} {lindex.n tcl/lists/lindex} {linsert.n tcl/lists/linsert} {list.n tcl/lists/list} {llength.n tcl/lists/llength} {load.n tcl/libraries/load} {lrange.n tcl/lists/lrange} {lreplace.n tcl/lists/lreplace} {lsearch.n tcl/lists/lsearch} {lsort.n tcl/lists/lsort} {msgcat.n tcl/intl/msgcat} {namespace.n tcl/variables/namespace} {open.n tcl/files/open} {package.n tcl/libraries/package} {pid.n tcl/processes/pid} {pkgMkIndex.n tcl/libraries/pkgMkIndex} {proc.n tcl/control/proc} {puts.n tcl/files/puts} {pwd.n tcl/status/pwd} {read.n tcl/files/read} {regexp.n tcl/strings/regexp} {re_syntax.n tcl/strings/re_syntax} {registry.n tcl/files/registry} {regsub.n tcl/strings/regsub} {rename.n tcl/control/rename} {return.n tcl/control/return} {safe.n tcl/control/safe} {scan.n tcl/strings/scan} {seek.n tcl/files/seek} {set.n tcl/variables/set} {source.n tcl/control/source} {split.n tcl/lists/split} {string.n tcl/strings/string} {subst.n tcl/strings/subst} {switch.n tcl/control/switch} {tell.n tcl/files/tell} {time.n tcl/time/time} {trace.n tcl/variables/trace} {unknown.n tcl/libraries/unknown} {unset.n tcl/variables/unset} {uplevel.n tcl/control/uplevel} {upvar.n tcl/variables/upvar} {while.n tcl/control/while} {tclvars.n tcl/variables/stdvars} {socket.n tcl/sockets/socket} {update.n tcl/events/update} {variable.n tcl/variables/variable} {vwait.n tcl/events/vwait} {tclsh.1 tcl/intro/tclsh} } if {$tcl_version <= 8.4} { lappend docs {resource.n tcl/files/resource} } if {$tcl_version >= 8.4} { lappend docs {lset.n tcl/lists/lset} } return $docs tclx8.4-8.4.1.orig/unix/tools/cphelpdir.sh0000644000000000000000000000254312046313167015215 0ustar # # cphelpdir.sh -- # # Script for copying a help tree from the source directory to the build # directory. If the source and build directories are the same, a warning # is issued. # # Arguments: # $1 - source help directory. # $2 - build help directory. #------------------------------------------------------------------------------ # Copyright 1993-1999 Karl Lehenbauer and Mark Diekhans. # # Permission to use, copy, modify, and distribute this software and its # documentation for any purpose and without fee is hereby granted, provided # that the above copyright notice appear in all copies. Karl Lehenbauer and # Mark Diekhans make no representations about the suitability of this # software for any purpose. It is provided "as is" without express or # implied warranty. #------------------------------------------------------------------------------ # $Id: cphelpdir.sh,v 8.3 1999/03/31 06:37:59 markd Exp $ #------------------------------------------------------------------------------ # SRC=$1 BUILD=$2 FOUND=notok if [ -d $SRC ] then SRCBRF=`(cd $SRC; echo *.brf)` if [ "$SRCBRF" != "*.brf" ] then FOUND=ok fi fi if [ "$FOUND" = "notok" ] then echo "***" echo "*** help files not found. Run \"make buildhelp\" to generate" echo "***" exit 1 else ../runtcl ../tools/instcopy -dirname $SRC $BUILD exit $? fi tclx8.4-8.4.1.orig/unix/tools/runbuildhelp.tcl0000644000000000000000000000245212046313167016107 0ustar # # runbuildhelp.tcl -- # # Wrapper to invoke buildhelp proc since standard tclsh doesn't have -c #------------------------------------------------------------------------------ # Copyright 2002 Karl Lehenbauer and Mark Diekhans. # # Permission to use, copy, modify, and distribute this software and its # documentation for any purpose and without fee is hereby granted, provided # that the above copyright notice appear in all copies. Karl Lehenbauer and # Mark Diekhans make no representations about the suitability of this # software for any purpose. It is provided "as is" without express or # implied warranty. #------------------------------------------------------------------------------ # $Id: runbuildhelp.tcl,v 8.1 2002/11/12 21:35:31 karll Exp $ #------------------------------------------------------------------------------ # package require Tclx source $env(TCLX_LIBRARY)/buildhelp.tcl #----------------------------------------------------------------------------- # Main program for building help from manual files. Constructs tmp input # file for the buildhelp command. if {[llength $argv] != 3} { puts stderr "wrong # args: $argv0 helpdir brief File.n" exit 1 } set helpDir [lindex $argv 0] set brief [lindex $argv 1] set dotN [lindex $argv 2] buildhelp $helpDir $brief $dotN exit 0 tclx8.4-8.4.1.orig/unix/tools/libconvert.tcl0000644000000000000000000000221012046313167015551 0ustar # # libconvert.tcl -- # # Interface to the convert_lib that doesn't go through the auto-load # mechanism. This helps if something is broken with auto-load so the # build at least completes. #------------------------------------------------------------------------------ # Copyright 1992-1999 Karl Lehenbauer and Mark Diekhans. # # Permission to use, copy, modify, and distribute this software and its # documentation for any purpose and without fee is hereby granted, provided # that the above copyright notice appear in all copies. Karl Lehenbauer and # Mark Diekhans make no representations about the suitability of this # software for any purpose. It is provided "as is" without express or # implied warranty. #------------------------------------------------------------------------------ # $Id: libconvert.tcl,v 8.3 1999/03/31 06:37:59 markd Exp $ #------------------------------------------------------------------------------ # if ![info exists env(TCLX_LIBRARY)] { puts stderr "This script is to only be used during the build run by" puts stderr "the `runtcl' script." exit 1 } source $tclx_library/tcl.tlib eval convert_lib $argv tclx8.4-8.4.1.orig/unix/tools/checkup.tcl0000644000000000000000000000553412046313167015040 0ustar # # checkup.tcl -- # # Program to try to detect various serious problems during the build. These # are problems that are known and can be confusing to the user, so we check # during the compile phase. # # Problems checked for: # o Detects broken glob and readdir command. This is a common problem # encountered when building Tcl & TclX on Solaris systems. If you compile # with /usr/ucb/cc you get readdir entries that don't match the include # file. This program *MUST* be run in the src directory where TclX was # built. # o Checks for modern functionality that is missing from the version of # Unix we are compiled on. Hopefully this will alert people to improper # configuration. #------------------------------------------------------------------------------ # Copyright 1995-1999 Karl Lehenbauer and Mark Diekhans. # # Permission to use, copy, modify, and distribute this software and its # documentation for any purpose and without fee is hereby granted, provided # that the above copyright notice appear in all copies. Karl Lehenbauer and # Mark Diekhans make no representations about the suitability of this # software for any purpose. It is provided "as is" without express or # implied warranty. #------------------------------------------------------------------------------ # $Id: checkup.tcl,v 8.3 1999/03/31 06:37:59 markd Exp $ #------------------------------------------------------------------------------ # # # Report file that was not found and exit. # proc ReportError {chkfile cmd} { puts stderr "*************************************************************" puts stderr "Unable to find $chkfile in the output of the TclX command" puts stderr "'$cmd' when run in the src directory. This indicates" puts stderr "that $cmd is broken. If your are running Solaris this" puts stderr "can be caused by compiling Tcl or TclX with the /usr/ucb/cc" puts stderr "compiler. If this is the case, move /usr/ucb to the end" puts stderr "of your path or see the INSTALL documentation for information" puts stderr "on specifying a different C compiler. Do a 'make clean'," puts stderr "'configure' and 'make' for both Tcl and TclX." puts stderr "Good luck." puts stderr "*************************************************************" exit 1 } # # Check for files that can not be found. # o dirlist - Contents of either the glob or the readdir command on the src # directory. # o cmd - The command that was used. # proc CheckDirList {dirlist cmd} { foreach chkfile {Makefile tclxConfig.sh tcl} { if {[lsearch $dirlist $chkfile] < 0} { ReportError $chkfile $cmd } } } CheckDirList [glob *] glob CheckDirList [readdir .] readdir # # Print a message about missing functionality. If its the first time, print # a header. # proc MissingMsg {msg} { # Not done yet. } tclx8.4-8.4.1.orig/unix/tools/genindex.tcl0000644000000000000000000000203012046313167015203 0ustar # # genindex.tcl -- # # Interface to the buildpackageindex that doesn't go through the auto-load # mechanism. This helps if something is broken with auto-load so the # build at least completes. #------------------------------------------------------------------------------ # Copyright 1992-1999 Karl Lehenbauer and Mark Diekhans. # # Permission to use, copy, modify, and distribute this software and its # documentation for any purpose and without fee is hereby granted, provided # that the above copyright notice appear in all copies. Karl Lehenbauer and # Mark Diekhans make no representations about the suitability of this # software for any purpose. It is provided "as is" without express or # implied warranty. #------------------------------------------------------------------------------ # $Id: genindex.tcl,v 8.4 1999/03/31 06:37:59 markd Exp $ #------------------------------------------------------------------------------ # #cmdtrace on global tclx_library source [file join $tclx_library buildidx.tcl] buildpackageindex $argv tclx8.4-8.4.1.orig/unix/tools/instcopy.tcl0000644000000000000000000000721012046313167015257 0ustar # # instcopy.tcl -- # # Tcl program to copy files during the installation of Tcl. This is used # because "copy -r" is not ubiquitous. It also adds some minor additional # functionality. # #------------------------------------------------------------------------------ # Copyright 1992-1999 Karl Lehenbauer and Mark Diekhans. # # Permission to use, copy, modify, and distribute this software and its # documentation for any purpose and without fee is hereby granted, provided # that the above copyright notice appear in all copies. Karl Lehenbauer and # Mark Diekhans make no representations about the suitability of this # software for any purpose. It is provided "as is" without express or # implied warranty. #------------------------------------------------------------------------------ # $Id: instcopy.tcl,v 8.7 2002/11/12 21:35:31 karll Exp $ #------------------------------------------------------------------------------ # # It is run in the following manner: # # instcopy file1 file2 ... targetdir # instcopy -filename file1 targetfile # # o -filename - If specified, then the last file is the name of a file rather # than a directory. # o -bin - Force file to be copied without translation. (not implemented). # o files - List of files to copy. If one of directories are specified, they # are copied. # o targetdir - Target directory to copy the files to. If the directory does # not exist, it is created (including parent directories). #:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: package require Tclx source [file join [file dirname [info script]] buildutil.tcl] #------------------------------------------------------------------------------ # Usage -- # # Issue a usage message and exit. #------------------------------------------------------------------------------ proc Usage {{msg {}}} { if {"$msg" != ""} { puts stderr "Error: $msg" } puts stderr {usage: instcopy ?-filename? file1 file2 ... targetdir} exit 1 } #------------------------------------------------------------------------------ # DoACopy -- #------------------------------------------------------------------------------ proc DoACopy {file target mode} { if [cequal [file tail $file] "CVS"] { return } if {$mode == "FILENAME"} { set targetDir [file dirname $target] if [file exists $target] { file delete -force $target } } else { set targetDir $target } file mkdir $targetDir if [file isdirectory $file] { CopyDir $file $target } else { CopyFile $file $target } } #------------------------------------------------------------------------------ # Main program code. #------------------------------------------------------------------------------ # # Parse the arguments # if {$argc < 2} { Usage "Not enough arguments" } set mode {} set binary 0 while {[string match -* [lindex $argv 0]]} { set flag [lvarpop argv] incr argc -1 switch -exact -- $flag { -filename { set mode FILENAME } -bin { set binary 1 } default { puts stderr "unknown flag" } } } set files {} foreach file [lrange $argv 0 [expr $argc-2]] { lappend files [eval file join [file split $file]] } set targetDir [eval file join [file split [lindex $argv [expr $argc-1]]]] if {[file exists $targetDir] && ![file isdirectory $targetDir] && ($mode != "FILENAME")} { Usage "Target is not a directory: $targetDir" } umask 022 if [catch { foreach file $files { DoACopy $file $targetDir $mode } } msg] { puts stderr "Error: $msg" exit 1 } tclx8.4-8.4.1.orig/unix/tools/cpmanpages.tcl0000644000000000000000000002475712046313167015544 0ustar # # cpmanpages.tcl -- # # Tool used during build to copy manual pages to master directories. This # program knows the internals of the build, so its very specific to this # task. # # It is run in the following manner: # # cpmanpages ?flags? separator cmd func unix sourceDir targetDir # # flags are: # o -rmcat - remove any existing "cat" files associated with man pages. # # arguments are: # o separator - Either "." or "", the separator in the manual page directory # name (/usr/man/man1 vs /usr/man/man.1). # o cmd - Section to put the Tcl command manual pages in. (*.n pages). # o func - Section to put the Tcl C function manual pages in. (*.3 pages). # o unix - Section to put the Tcl Unix command manual pages in. # Maybe empty. (*.1 pages). # o sourceDir - directory containing manual pages to install. # o targetDir - manual directory to install pages in. This is the directory # containing the section directories, e.g. /usr/local/man. # # If any of these strings are quoted with "@" (e.g. @.@), then the two "@" # are removed. This is to work around problems with systems were quoted empty # strings don't make it past make and shell expansion, resulting in a missing # argument. #------------------------------------------------------------------------------ # Copyright 1992-1999 Karl Lehenbauer and Mark Diekhans. # # Permission to use, copy, modify, and distribute this software and its # documentation for any purpose and without fee is hereby granted, provided # that the above copyright notice appear in all copies. Karl Lehenbauer and # Mark Diekhans make no representations about the suitability of this # software for any purpose. It is provided "as is" without express or # implied warranty. #------------------------------------------------------------------------------ # $Id: cpmanpages.tcl,v 8.4 1999/03/31 06:37:59 markd Exp $ #------------------------------------------------------------------------------ # #------------------------------------------------------------------------------ # Unquote -- # # Remove "@" if they quote a string. #------------------------------------------------------------------------------ proc Unquote str { regsub -- {^@(.*)@$} $str {\1} str return $str } #------------------------------------------------------------------------------ # CopyManFile -- # # Called to open a copy a man file. Recursively called to include .so files. #------------------------------------------------------------------------------ proc CopyManFile {sourceFile targetFH} { set sourceFH [open $sourceFile r] while {[gets $sourceFH line] >= 0} { if [string match {.V[SE]*} $line] continue if [string match {.so *} $line] { set soFile [string trim [crange $line 3 end]] CopyManFile "[file dirname $sourceFile]/$soFile" $targetFH continue } puts $targetFH $line } close $sourceFH } #------------------------------------------------------------------------------ # CopyManPage -- # # Copy the specified manual page and change the ownership. The manual page # is edited to remove change bars (.VS and .VE macros). Files included with .so # are merged in. #------------------------------------------------------------------------------ proc CopyManPage {sourceFile targetFile} { global gzip if ![file exists [file dirname $targetFile]] { mkdir -path [file dirname $targetFile] } catch {file delete $targetFile $targetFile.gz} set targetFH [open $targetFile w] CopyManFile $sourceFile $targetFH close $targetFH if $gzip { exec gzip -9f $targetFile } } #------------------------------------------------------------------------------ # GetManNames -- # # Search a manual page (nroff source) for the name line. Parse the name # line into all of the functions or commands that it references. This isn't # comprehensive, but it works for all of the Tcl, TclX and Tk man pages. # # Parameters: # o manFile (I) - The path to the manual page file. # Returns: # A list contain the functions or commands or {} if the name line can't be # found or parsed. #------------------------------------------------------------------------------ proc GetManNames manFile { set manFH [open $manFile] # # Search for name line. Once found, grab the next line that is not a # nroff macro. If we end up with a blank line, we didn't find it. # while {[gets $manFH line] >= 0} { if [regexp {^.SH NAME.*$} $line] { break } } while {[gets $manFH line] >= 0} { if {![string match ".*" $line]} break } close $manFH set line [string trim $line] if {$line == ""} return # # Lets try and parse the name list out of the line # if {![regexp {^(.*)(\\-)} $line {} namePart]} { if {![regexp {^(.*)(-)} $line {} namePart]} return } # # This magic converts the name line into a list # if {[catch {join [split $namePart ,] " "} namePart] != 0} return return $namePart } #------------------------------------------------------------------------------ # InstallShortMan -- # Install a manual page on a system that does not have long file names. # # Parameters: # o sourceFile - Manual page source file path. # o targetDir - Directory to install the file in. # o extension - Extension to use for the installed file. # Returns: # A list of the man files created, relative to targetDir. #------------------------------------------------------------------------------ proc InstallShortMan {sourceFile targetDir extension} { set manFileName "[file tail [file root $sourceFile]].$extension" CopyManPage $sourceFile "$targetDir/$manFileName" return $manFileName } #------------------------------------------------------------------------------ # InstallLongMan -- # Install a manual page on a system that has long file names. # # Parameters: # o sourceFile - Manual page source file path. # o targetDir - Directory to install the file in. # o extension - Extension to use for the installed file. # Returns: # A list of the man files created, relative to targetDir. They are all links # to the same entry. #------------------------------------------------------------------------------ proc InstallLongMan {sourceFile targetDir extension} { global gzip set manNames [GetManNames $sourceFile] if [lempty $manNames] { set baseName [file tail [file root $sourceFile]] puts stderr "Warning: can't parse NAME line for man page: $sourceFile." puts stderr " Manual page only available as: $baseName" set manNames [list [file tail [file root $sourceFile]]] } # Copy file to the first name in the list. set firstFilePath $targetDir/[lvarpop manNames].$extension set created [list [file tail $firstFilePath]] CopyManPage $sourceFile $firstFilePath # Link it to the rest of the names in the list. foreach manName $manNames { set targetFile $targetDir/$manName.$extension file delete $targetFile $targetFile.gz if $gzip { set cmd "link $firstFilePath.gz $targetFile.gz" } else { set cmd "link $firstFilePath $targetFile" } if {[catch { eval $cmd } msg] != 0} { puts stderr "error from: $cmd" puts stderr " $msg" } else { lappend created [file tail $targetFile] } } return $created } #------------------------------------------------------------------------------ # InstallManPage -- # Install a manual page on a system. # # Parameters: # o sourceFile - Manual page source file path. # o manDir - Directory to build the directoy containing the manual files in. # o section - Section to install the manual page in. # Globals # o longNames - If long file names are supported. # o manSeparator - Character used to seperate man directory name from the # section name. # o rmcat - true if cat files are to be removed. #------------------------------------------------------------------------------ proc InstallManPage {sourceFile manDir section} { global longNames manSeparator rmcat set targetDir "$manDir/man${manSeparator}${section}" if $longNames { set files [InstallLongMan $sourceFile $targetDir $section] } else { set files [InstallShortMan $sourceFile $targetDir $section] } if $rmcat { foreach file $files { catch { file delete [list $manDir/cat${manSeparator}${section}/$file] } } } } #------------------------------------------------------------------------------ # main prorgam umask 022 # Parse command line args set rmcat 0 set gzip 0 while {[string match -* $argv]} { set opt [lvarpop argv] switch -- $opt { -rmcat {set rmcat 1} -gzip {set gzip 1} default { puts stderr "unknown flag: $opt" } } } if {[llength $argv] != 6} { puts stderr "wrong # args: cpmanpages ?flags? separator cmd func unix sourceDir targetDir" exit 1 } set manSeparator [Unquote [lindex $argv 0]] set sectionXRef(.n) [Unquote [lindex $argv 1]] set sectionXRef(.3) [Unquote [lindex $argv 2]] set sectionXRef(.1) [Unquote [lindex $argv 3]] set sourceDir [Unquote [lindex $argv 4]] set targetDir [Unquote [lindex $argv 5]] # Remove undefined sections from the array. foreach sec [array names sectionXRef] { if [lempty sectionXRef($sec)] { unset sectionXRef($sec) } } puts stdout "Copying manual pages from $sourceDir to $targetDir" # Determine if long file names are available. if ![file exists $targetDir] { mkdir -path $targetDir } set testName "$targetDir/TclX-long-test-file-name" if [catch {open $testName w} fh] { puts stdout "" puts stdout "*** NOTE: long file names do not appear to be available on" puts stdout "*** this system. Attempt to create a long named file in" puts stdout "*** $targetDir returned the error: $errorCode" puts stdout "" set longNames 0 } else { close $fh file delete $testName set longNames 1 } set sourceFiles [glob -- $sourceDir/*.n $sourceDir/*.1 $sourceDir/*.3] set ignoreFiles {} # Actually install the files. foreach sourceFile $sourceFiles { if {[lsearch $ignoreFiles [file tail $sourceFile]] >= 0} continue set ext [file extension $sourceFile] if ![info exists sectionXRef($ext)] { puts stderr "WARNING: Don't know how to handle section for $sourceFile," continue } InstallManPage $sourceFile $targetDir $sectionXRef($ext) } tclx8.4-8.4.1.orig/unix/tools/bldmanhelp.tcl0000644000000000000000000001141412046313167015516 0ustar # # bldmanhelp.tcl -- # # Build help files from the manual pages. This uses a table of manual # pages, sections. Brief entries are extracted from the name line. # This is not installed as part of Extended Tcl, its just used during the # build phase. # # This program is very specific to extracting manual files from John # Ousterhout's Tcl and Tk man pages. Its not general. # # The command line is: # # bldmanhelp docdir maninfo helpdir # # Where: # o docdir is the directory containing the manual pages. # o maninfo is the path to a file that when sources returns a list of # entries describing manual pages to convert. Each entry is a list # of manual file and the path of the help file to generate. # o helpdir is the directory to create the help files in. # o brief is the brief file to create. #------------------------------------------------------------------------------ # Copyright 1992-1999 Karl Lehenbauer and Mark Diekhans. # # Permission to use, copy, modify, and distribute this software and its # documentation for any purpose and without fee is hereby granted, provided # that the above copyright notice appear in all copies. Karl Lehenbauer and # Mark Diekhans make no representations about the suitability of this # software for any purpose. It is provided "as is" without express or # implied warranty. #------------------------------------------------------------------------------ # $Id: bldmanhelp.tcl,v 8.5 2002/11/12 21:35:31 karll Exp $ #------------------------------------------------------------------------------ # package require Tclx # # pull in buildhelp procs # source $env(TCLX_LIBRARY)/buildhelp.tcl # # Flag indicating if errors occured. # set gotErrors 0 #----------------------------------------------------------------------------- # Process the name section. This is used to generate a @brief: entry. # It returns the line that was read. proc ProcessNameSection {manFH outFH} { set line [gets $manFH] case [lindex $line 0] { {.HS .BS .BE .VS .VE} { set line [gets $manFH] } } set brief [string trim [crange $line [string first - $line]+1 end]] puts $outFH "'\\\"@brief: $brief" return $line } #----------------------------------------------------------------------------- # Copy the named manual page source to the target, recursively including # .so files. Remove macros usages that don't work good in a help file. proc CopyManPage {manPage outFH} { global skipSection set stat [catch { open $manPage } fh] if {$stat != 0} { global gotErrors set gotErrors 1 puts stderr "can't open \"$manPage\" $fh" return } while {[gets $fh line] >= 0} { switch -glob -- $line { .so* { CopyManPage [lindex $line 1] $outFH } .SH* { puts $outFH $line if {[lindex $line 1] == "NAME"} { set line [ProcessNameSection $fh $outFH] puts $outFH $line } } .HS* - .BS* - .BE* - .VS* - .VE* - .TH* { } default { if !$skipSection { puts $outFH $line } } } } close $fh } #----------------------------------------------------------------------------- # Process a manual file and copy it to the temporary file. Assumes current # dir is the directory containing the manual files. proc ProcessManFile {ent tmpFH} { global skipSection set skipSection 0 puts $tmpFH "'\\\"@help: [lindex $ent 1]" CopyManPage [lindex $ent 0] $tmpFH puts $tmpFH "'\\\"@endhelp" } #----------------------------------------------------------------------------- # Procedure to create a temporary file containing the file constructed # for input to buildhelp. # proc GenInputFile {docDir manInfoTbl tmpFile} { set tmpFH [open $tmpFile w] set cwd [pwd] cd $docDir foreach ent $manInfoTbl { puts stdout " preprocessing $ent" ProcessManFile $ent $tmpFH } cd $cwd close $tmpFH } #----------------------------------------------------------------------------- # Main program for building help from manual files. Constructs tmp input # file for the buildhelp command. if {[llength $argv] != 4} { puts stderr "wrong # args: bldmanhelp docdir maninfo helpdir brief" exit 1 } set tmpFile "bldmanhelp.tmp" set docDir [lindex $argv 0] set manInfoTbl [source [lindex $argv 1]] set helpDir [lindex $argv 2] set brief [lindex $argv 3] puts stdout "Begin preprocessing UCB manual files" GenInputFile $docDir $manInfoTbl $tmpFile buildhelp $helpDir $brief [list $tmpFile] file delete -force $tmpFile if $gotErrors { puts stderr "Errors occured processing manual files" exit 1 } exit 0 tclx8.4-8.4.1.orig/unix/tools/tkmanpages0000644000000000000000000000576612046313167014776 0ustar # # tkmanpages -- # # Manual info file to be sources by bldmanhelp.tcl that returns a table # describing the Tk manual to build the help files from. #------------------------------------------------------------------------------ # Copyright 1992-1999 Karl Lehenbauer and Mark Diekhans. # # Permission to use, copy, modify, and distribute this software and its # documentation for any purpose and without fee is hereby granted, provided # that the above copyright notice appear in all copies. Karl Lehenbauer and # Mark Diekhans make no representations about the suitability of this # software for any purpose. It is provided "as is" without express or # implied warranty. #------------------------------------------------------------------------------ # $Id: tkmanpages,v 8.6 1999/06/24 01:09:07 redman Exp $ #------------------------------------------------------------------------------ # return { {bell.n tk/control/bell} {bind.n tk/control/bind} {bindtags.n tk/control/bindtags} {bitmap.n tk/images/bitmap} {button.n tk/widgets/button} {canvas.n tk/widgets/canvas} {checkbutton.n tk/widgets/checkbutton} {chooseColor.n tk/widgets/tk_chooseColor} {clipboard.n tk/control/clipboard} {destroy.n tk/control/destroy} {dialog.n tk/widgets/tk_dialog} {entry.n tk/widgets/entry} {event.n tk/control/event} {focus.n tk/control/focus} {focusNext.n tk/control/tk_focusNext} {font.n tk/control/font} {frame.n tk/widgets/frame} {getOpenFile.n tk/widgets/tk_getOpenFile} {grab.n tk/control/grab} {grid.n tk/control/grid} {image.n tk/images/image} {label.n tk/widgets/label} {listbox.n tk/widgets/listbox} {loadTk.n tk/control/loadTk} {lower.n tk/control/lower} {menu.n tk/widgets/menu} {menubar.n tk/widgets/tk_menuBar} {menubutton.n tk/widgets/menubutton} {message.n tk/widgets/message} {messageBox.n tk/widgets/tk_messageBox} {option.n tk/control/option} {optionMenu.n tk/widgets/tk_optionMenu} {options.n tk/widgets/options} {pack.n tk/control/pack} {pack-old.n tk/control/pack-old} {palette.n tk/control/tk_setPalette} {palette.n tk/control/tk_bisque} {photo.n tk/images/photo} {place.n tk/control/place} {popup.n tk/widgets/tk_popup} {radiobutton.n tk/widgets/radiobutton} {raise.n tk/control/raise} {scale.n tk/widgets/scale} {scrollbar.n tk/widgets/scrollbar} {selection.n tk/control/selection} {send.n tk/control/send} {text.n tk/widgets/text} {tk.n tk/control/tk} {tkerror.n tk/control/tkerror} {tkvars.n tk/control/tkvars} {tkwait.n tk/control/tkwait} {toplevel.n tk/widgets/toplevel} {winfo.n tk/control/winfo} {wm.n tk/control/wm} } tclx8.4-8.4.1.orig/unix/tclXunixDup.c0000644000000000000000000002116412046313167014202 0ustar /* * tclXunixDup.c * * Support for the dup command on Unix. *----------------------------------------------------------------------------- * Copyright 1991-1999 Karl Lehenbauer and Mark Diekhans. * * Permission to use, copy, modify, and distribute this software and its * documentation for any purpose and without fee is hereby granted, provided * that the above copyright notice appear in all copies. Karl Lehenbauer and * Mark Diekhans make no representations about the suitability of this * software for any purpose. It is provided "as is" without express or * implied warranty. *----------------------------------------------------------------------------- * $Id: tclXunixDup.c,v 8.1 2001/10/24 23:31:50 hobbs Exp $ *----------------------------------------------------------------------------- */ #include "tclExtdInt.h" /* * Prototypes of internal functions. */ static int ConvertFileHandle _ANSI_ARGS_((Tcl_Interp *interp, char *handle)); /*----------------------------------------------------------------------------- * ConvertFileHandle -- * * Convert a file handle to its file number. The file handle maybe one * of "stdin", "stdout" or "stderr" or "fileNNN", were NNN is the file * number. If the handle is invalid, -1 is returned and a error message * will be returned in result. This is used when the file may * not be currently open. * *----------------------------------------------------------------------------- */ static int ConvertFileHandle (interp, handle) Tcl_Interp *interp; char *handle; { int fileId = -1; if (handle [0] == 's') { if (STREQU (handle, "stdin")) fileId = 0; else if (STREQU (handle, "stdout")) fileId = 1; else if (STREQU (handle, "stderr")) fileId = 2; } else { if (STRNEQU (handle, "file", 4)) TclX_StrToInt (&handle [4], 10, &fileId); if (STRNEQU (handle, "sock", 4)) TclX_StrToInt (&handle [4], 10, &fileId); } if (fileId < 0) TclX_AppendObjResult (interp, "invalid channel id: ", handle, (char *) NULL); return fileId; } /*----------------------------------------------------------------------------- * TclXOSDupChannel -- * OS dependent duplication of a channel. * * Parameters: * o interp (I) - If an error occures, the error message is in result. * o srcChannel (I) - The channel to dup. * o mode (I) - The channel mode. * o targetChannelId (I) - The id for the new file. NULL if any id maybe * used. * Returns: * The unregistered new channel, or NULL if an error occured. *----------------------------------------------------------------------------- */ Tcl_Channel TclXOSDupChannel (interp, srcChannel, mode, targetChannelId) Tcl_Interp *interp; Tcl_Channel srcChannel; int mode; char *targetChannelId; { ClientData handle; Tcl_ChannelType *channelType; Tcl_Channel newChannel = NULL; int srcFileNum, newFileNum = -1; /* * On Unix, the channels we can dup share the same file for the read and * write directions, so use either. Duping of pipelines can't work. */ if (mode & TCL_READABLE) { Tcl_GetChannelHandle (srcChannel, TCL_READABLE, &handle); } else { Tcl_GetChannelHandle (srcChannel, TCL_WRITABLE, &handle); } srcFileNum = (int) handle; channelType = Tcl_GetChannelType (srcChannel); /* * If a target id is specified, close that channel if its open. Dup * the file. */ if (targetChannelId != NULL) { Tcl_Channel oldChannel; int chkFileNum; newFileNum = ConvertFileHandle (interp, targetChannelId); if (newFileNum < 0) return NULL; oldChannel = Tcl_GetChannel (interp, targetChannelId, NULL); if (oldChannel != NULL) { Tcl_UnregisterChannel (interp, oldChannel); } chkFileNum = dup2 (srcFileNum, newFileNum); if (chkFileNum < 0) goto posixError; if (chkFileNum != newFileNum) { TclX_AppendObjResult (interp, "dup: desired file number not ", "returned", (char *) NULL); close (newFileNum); return NULL; } } else { newFileNum = dup (srcFileNum); if (newFileNum < 0) goto posixError; } if (STREQU (channelType->typeName, "tcp")) { newChannel = Tcl_MakeTcpClientChannel ((ClientData) newFileNum); } else { newChannel = Tcl_MakeFileChannel ((ClientData) newFileNum, mode); } return newChannel; posixError: Tcl_ResetResult (interp); TclX_AppendObjResult (interp, "dup of \"", Tcl_GetChannelName (srcChannel), " failed: ", Tcl_PosixError (interp), (char *) NULL); return NULL; } /*----------------------------------------------------------------------------- * TclXOSBindOpenFile -- * Bind a open file number of a channel. * * Parameters: * o interp (I) - If an error occures, the error message is in result. * o fileNum (I) - The file number of the open file. * Returns: * The unregistered channel or NULL if an error occurs. *----------------------------------------------------------------------------- */ Tcl_Channel TclXOSBindOpenFile (interp, fileNum) Tcl_Interp *interp; int fileNum; { int fcntlMode; int mode = 0; int nonBlocking; int isSocket; struct stat fileStat; char channelName[20]; Tcl_Channel channel = NULL; /* * Make sure file is open and determine the access mode and file type. */ fcntlMode = fcntl (fileNum, F_GETFL, 0); if (fcntlMode == -1) goto posixError; switch (fcntlMode & O_ACCMODE) { case O_RDONLY: mode = TCL_READABLE; break; case O_WRONLY: mode = TCL_WRITABLE; break; case O_RDWR: mode = TCL_READABLE | TCL_WRITABLE; break; } nonBlocking = ((fcntlMode & (O_NONBLOCK | O_NDELAY)) != 0); if (fstat (fileNum, &fileStat) < 0) goto posixError; /* * If its a socket but RDONLY or WRONLY, enter it as a file. This is * a pipe under BSD. */ isSocket = S_ISSOCK (fileStat.st_mode) && (mode == (TCL_READABLE | TCL_WRITABLE)) ; /* * FIX: some FreeBSD 2.2 SNAPs claim that a pipe is a socket, event though * they are not implemented as such, which causes socket operations to * fail is we bind it to a socket channel. If it claims to be a socket, * the times will tell the difference, they are zero for sockets. */ #ifdef __FreeBSD__ if (isSocket && (fileStat.st_ctime != 0)) isSocket = FALSE; #endif if (isSocket) sprintf (channelName, "sock%d", fileNum); else sprintf (channelName, "file%d", fileNum); if (Tcl_GetChannel (interp, channelName, NULL) != NULL) { char numBuf [32]; Tcl_ResetResult (interp); sprintf (numBuf, "%d", fileNum); TclX_AppendObjResult (interp, "file number \"", numBuf, "\" is already bound to a Tcl file ", "channel", (char *) NULL); return NULL; } Tcl_ResetResult (interp); if (isSocket) { channel = Tcl_MakeTcpClientChannel ((ClientData) fileNum); } else { channel = Tcl_MakeFileChannel ((ClientData) fileNum, mode); } Tcl_RegisterChannel (interp, channel); /* * Set channel options. */ if (nonBlocking) { if (TclX_SetChannelOption (interp, channel, TCLX_COPT_BLOCKING, TCLX_MODE_NONBLOCKING) == TCL_ERROR) goto errorExit; } if (isatty (fileNum)) { if (TclX_SetChannelOption (interp, channel, TCLX_COPT_BUFFERING, TCLX_BUFFERING_LINE) == TCL_ERROR) goto errorExit; } return channel; posixError: { char numBuf [32]; Tcl_ResetResult (interp); sprintf (numBuf, "%d", fileNum); TclX_AppendObjResult (interp, "binding open file ", numBuf, " to Tcl channel failed: ", Tcl_PosixError (interp), (char *) NULL); } errorExit: if (channel != NULL) { Tcl_UnregisterChannel (interp, channel); } return NULL; } tclx8.4-8.4.1.orig/unix/tclXunixOS.c0000644000000000000000000015710212046313167013775 0ustar /* * tclXunixOS.c -- * * OS system dependent interface for Unix systems. The idea behind these * functions is to provide interfaces to various functions that vary on the * various platforms. These functions either implement the call in a manner * approriate to the platform or return an error indicating the functionality * is not available on that platform. This results in code with minimal * number of #ifdefs. *----------------------------------------------------------------------------- * Copyright 1996-1999 Karl Lehenbauer and Mark Diekhans. * * Permission to use, copy, modify, and distribute this software and its * documentation for any purpose and without fee is hereby granted, provided * that the above copyright notice appear in all copies. Karl Lehenbauer and * Mark Diekhans make no representations about the suitability of this * software for any purpose. It is provided "as is" without express or * implied warranty. *----------------------------------------------------------------------------- * $Id: tclXunixOS.c,v 8.9 2005/07/12 19:03:15 hobbs Exp $ *----------------------------------------------------------------------------- */ #include "tclExtdInt.h" #ifndef NO_GETPRIORITY #include #endif /* * Tcl 8.4 had some weird and unnecessary ifdef'ery for readdir * readdir() should be thread-safe according to the Single Unix Spec. * [Bug #1095909] */ #ifdef readdir #undef readdir #endif /* * Cheat a little to avoid configure checking for floor and ceil being * This breaks with GNU libc headers...really should check with autoconf. */ #ifndef __GNU_LIBRARY__ extern double floor (); extern double ceil (); #endif /* * Prototypes of internal functions. */ static int ChannelToFnum _ANSI_ARGS_((Tcl_Channel channel, int direction)); static int ConvertOwnerGroup _ANSI_ARGS_((Tcl_Interp *interp, unsigned options, char *ownerStr, char *groupStr, uid_t *ownerId, gid_t *groupId)); /*----------------------------------------------------------------------------- * TclXNotAvailableError -- * Return an error about functionality not being available under Windows. * * Parameters: * o interp - Errors returned in result. * o funcName - Command or other name to use in not available error. * Returns: * TCL_ERROR. *----------------------------------------------------------------------------- */ int TclXNotAvailableError (interp, funcName) Tcl_Interp *interp; char *funcName; { TclX_AppendObjResult (interp, funcName, " is not available on this system", (char *) NULL); return TCL_ERROR; } /*----------------------------------------------------------------------------- * ChannelToFnum -- * * Convert a channel to a file number. * * Parameters: * o channel - Channel to get file number for. * o direction - TCL_READABLE or TCL_WRITABLE, or zero. If zero, then * return the first of the read and write numbers. * Returns: * The file number or -1 if a file number is not associated with this access * direction. Normally the resulting file number is just passed to a system * call and let the system calls generate an error when -1 is returned. *----------------------------------------------------------------------------- */ static int ChannelToFnum (channel, direction) Tcl_Channel channel; int direction; { ClientData handle; if (direction == 0) { if (Tcl_GetChannelHandle (channel, TCL_READABLE, &handle) != TCL_OK && Tcl_GetChannelHandle (channel, TCL_WRITABLE, &handle) != TCL_OK) { return -1; } } else { if (Tcl_GetChannelHandle (channel, direction, &handle) != TCL_OK) { return -1; } } return (int) handle; } /*----------------------------------------------------------------------------- * TclXOSTicksToMS -- * * Convert clock ticks to milliseconds. * * Parameters: * o numTicks - Number of ticks. * Returns: * Milliseconds. *----------------------------------------------------------------------------- */ clock_t TclXOSTicksToMS (numTicks) clock_t numTicks; { static clock_t msPerTick = 0; /* * Some systems (SVR4) implement CLK_TCK as a call to sysconf, so lets only * reference it once in the life of this process. */ if (msPerTick == 0) msPerTick = CLK_TCK; if (msPerTick <= 100) { /* * On low resolution systems we can do this all with integer math. Note * that the addition of half the clock hertz results in appoximate * rounding instead of truncation. */ return (numTicks) * (1000 + msPerTick / 2) / msPerTick; } else { /* * On systems (Cray) where the question is ticks per millisecond, not * milliseconds per tick, we need to use floating point arithmetic. */ return ((numTicks) * 1000.0 / msPerTick); } } /*----------------------------------------------------------------------------- * TclXOSgetpriority -- * System dependent interface to getpriority functionality. * * Parameters: * o interp - Errors returned in result. * o priority - Process priority is returned here. * o funcName - Command or other name to use in not available error. * Results: * TCL_OK or TCL_ERROR. *----------------------------------------------------------------------------- */ int TclXOSgetpriority (interp, priority, funcName) Tcl_Interp *interp; int *priority; char *funcName; { #ifndef NO_GETPRIORITY *priority = getpriority (PRIO_PROCESS, 0); #else *priority = nice (0); #endif return TCL_OK; } /*----------------------------------------------------------------------------- * TclXOSincrpriority-- * System dependent interface to increment or decrement the current priority. * * Parameters: * o interp - Errors returned in result. * o priorityIncr - Amount to adjust the priority by. * o priority - The new priority.. * o funcName - Command or other name to use in not available error. * Results: * TCL_OK or TCL_ERROR. *----------------------------------------------------------------------------- */ int TclXOSincrpriority (interp, priorityIncr, priority, funcName) Tcl_Interp *interp; int priorityIncr; int *priority; char *funcName; { errno = 0; /* Old priority might be -1 */ #ifndef NO_GETPRIORITY *priority = getpriority (PRIO_PROCESS, 0) + priorityIncr; if (errno == 0) { setpriority (PRIO_PROCESS, 0, *priority); } #else *priority = nice (priorityIncr); #endif if (errno != 0) { TclX_AppendObjResult (interp, "failed to increment priority: ", Tcl_PosixError (interp), (char *) NULL); return TCL_ERROR; } return TCL_OK; } /*----------------------------------------------------------------------------- * TclXOSpipe -- * System dependent interface to create a pipes for the pipe command. * * Parameters: * o interp - Errors returned in result. * o channels - Two element array to return read and write channels in. * Results: * TCL_OK or TCL_ERROR. *----------------------------------------------------------------------------- */ int TclXOSpipe (interp, channels) Tcl_Interp *interp; Tcl_Channel *channels; { int fileNums [2]; if (pipe (fileNums) < 0) { TclX_AppendObjResult (interp, "pipe creation failed: ", Tcl_PosixError (interp), (char *) NULL); return TCL_ERROR; } channels [0] = Tcl_MakeFileChannel ((ClientData) fileNums [0], TCL_READABLE); Tcl_RegisterChannel (interp, channels [0]); channels [1] = Tcl_MakeFileChannel ((ClientData) fileNums [1], TCL_WRITABLE); Tcl_RegisterChannel (interp, channels [1]); return TCL_OK; } /*----------------------------------------------------------------------------- * TclXOSsetitimer -- * System dependent interface to setitimer functionality. * * Parameters: * o interp - Errors returned in result. * o seconds (I/O) - Seconds to pause for, it is updated with the time * remaining on the last alarm. * o funcName - Command or other name to use in not available error. * Results: * TCL_OK or TCL_ERROR. *----------------------------------------------------------------------------- */ int TclXOSsetitimer (interp, seconds, funcName) Tcl_Interp *interp; double *seconds; char *funcName; { /* * A million microseconds per seconds. */ #define TCL_USECS_PER_SEC (1000L * 1000L) #ifndef NO_SETITIMER double secFloor; struct itimerval timer, oldTimer; secFloor = floor (*seconds); timer.it_value.tv_sec = secFloor; timer.it_value.tv_usec = (long) ((*seconds - secFloor) * (double) TCL_USECS_PER_SEC); timer.it_interval.tv_sec = 0; timer.it_interval.tv_usec = 0; if (setitimer (ITIMER_REAL, &timer, &oldTimer) < 0) { TclX_AppendObjResult (interp, "unable to obtain timer: ", Tcl_PosixError (interp), (char *) NULL); return TCL_ERROR; } *seconds = oldTimer.it_value.tv_sec; *seconds += ((double) oldTimer.it_value.tv_usec) / ((double) TCL_USECS_PER_SEC); return TCL_OK; #else unsigned useconds; useconds = ceil (*seconds); *seconds = alarm (useconds); return TCL_OK; #endif } /*----------------------------------------------------------------------------- * TclXOSsleep -- * System dependent interface to sleep functionality. * * Parameters: * o seconds - Seconds to sleep. *----------------------------------------------------------------------------- */ void TclXOSsleep (seconds) unsigned seconds; { Tcl_Sleep (seconds*1000); } /*----------------------------------------------------------------------------- * TclXOSsync -- * System dependent interface to sync functionality. *----------------------------------------------------------------------------- */ void TclXOSsync () { sync (); } /*----------------------------------------------------------------------------- * TclXOSfsync -- * System dependent interface to fsync functionality. Does a sync if fsync * is not available. * * Parameters: * o interp - Errors returned in result. * o channel - The channel to sync. * Results: * TCL_OK or TCL_ERROR. *----------------------------------------------------------------------------- */ int TclXOSfsync (interp, channel) Tcl_Interp *interp; Tcl_Channel channel; { if (Tcl_Flush (channel) < 0) goto posixError; #ifndef NO_FSYNC if (fsync (ChannelToFnum (channel, TCL_WRITABLE)) < 0) goto posixError; #else sync (); #endif return TCL_OK; posixError: TclX_AppendObjResult (interp, Tcl_GetChannelName (channel), ": ", Tcl_PosixError (interp), (char *) NULL); return TCL_ERROR; } /*----------------------------------------------------------------------------- * TclXOSsystem -- * System dependent interface to system functionality (executing a command * with the standard system shell). * * Parameters: * o interp - Errors returned in result. * o command - Command to execute. * o exitCode - Exit code of the child process. * Results: * TCL_OK or TCL_ERROR. *----------------------------------------------------------------------------- */ int TclXOSsystem (interp, command, exitCode) Tcl_Interp *interp; char *command; int *exitCode; { int errPipes [2], childErrno; pid_t pid; WAIT_STATUS_TYPE waitStatus; errPipes [0] = errPipes [1] = -1; /* * Create a close on exec pipe to get status back from the child if * the exec fails. */ if (pipe (errPipes) != 0) { TclX_AppendObjResult (interp, "couldn't create pipe: ", Tcl_PosixError (interp), (char *) NULL); goto errorExit; } if (fcntl (errPipes [1], F_SETFD, FD_CLOEXEC) != 0) { TclX_AppendObjResult (interp, "couldn't set close on exec for pipe: ", Tcl_PosixError (interp), (char *) NULL); goto errorExit; } pid = fork (); if (pid == -1) { TclX_AppendObjResult (interp, "couldn't fork child process: ", Tcl_PosixError (interp), (char *) NULL); goto errorExit; } if (pid == 0) { close (errPipes [0]); execl ("/bin/sh", "sh", "-c", command, (char *) NULL); write (errPipes [1], &errno, sizeof (errno)); _exit (127); } close (errPipes [1]); if (read (errPipes [0], &childErrno, sizeof (childErrno)) > 0) { errno = childErrno; TclX_AppendObjResult (interp, "couldn't execing /bin/sh: ", Tcl_PosixError (interp), (char *) NULL); waitpid (pid, (int *) &waitStatus, 0); goto errorExit; } close (errPipes [0]); if (waitpid (pid, (int *) &waitStatus, 0) < 0) { TclX_AppendObjResult (interp, "wait failed: ", Tcl_PosixError (interp), (char *) NULL); return TCL_ERROR; } /* * Return status based on wait result. */ if (WIFEXITED (waitStatus)) { *exitCode = WEXITSTATUS (waitStatus); return TCL_OK; } if (WIFSIGNALED (waitStatus)) { Tcl_SetErrorCode (interp, "SYSTEM", "SIG", Tcl_SignalId (WTERMSIG (waitStatus)), (char *) NULL); TclX_AppendObjResult (interp, "system command terminate with signal ", Tcl_SignalId (WTERMSIG (waitStatus)), (char *) NULL); return TCL_ERROR; } /* * Should never get this status back unless the implementation is * really brain-damaged. */ if (WIFSTOPPED (waitStatus)) { TclX_AppendObjResult (interp, "system command child stopped", (char *) NULL); return TCL_ERROR; } errorExit: close (errPipes [0]); close (errPipes [1]); return TCL_ERROR; } /*----------------------------------------------------------------------------- * TclX_OSlink -- * System dependent interface to link functionality. * * Parameters: * o interp - Errors returned in result. * o srcPath - File to link. * o targetPath - Path to new link. * o funcName - Command or other name to use in not available error. * Results: * TCL_OK or TCL_ERROR. *----------------------------------------------------------------------------- */ int TclX_OSlink (interp, srcPath, targetPath, funcName) Tcl_Interp *interp; char *srcPath; char *targetPath; char *funcName; { if (link (srcPath, targetPath) != 0) { TclX_AppendObjResult (interp, "linking \"", srcPath, "\" to \"", targetPath, "\" failed: ", Tcl_PosixError (interp), (char *) NULL); return TCL_ERROR; } return TCL_OK; } /*----------------------------------------------------------------------------- * TclX_OSsymlink -- * System dependent interface to symlink functionality. * * Parameters: * o interp - Errors returned in result. * o srcPath - Value of symbolic link. * o targetPath - Path to new symbolic link. * o funcName - Command or other name to use in not available error. * Results: * TCL_OK or TCL_ERROR. *----------------------------------------------------------------------------- */ int TclX_OSsymlink (interp, srcPath, targetPath, funcName) Tcl_Interp *interp; char *srcPath; char *targetPath; char *funcName; { #ifdef S_IFLNK if (symlink (srcPath, targetPath) != 0) { TclX_AppendObjResult (interp, "creating symbolic link \"", targetPath, "\" failed: ", Tcl_PosixError (interp), (char *) NULL); return TCL_ERROR; } return TCL_OK; #else TclX_AppendObjResult (interp, "symbolic links are not supported on this", " Unix system", (char *) NULL); return TCL_ERROR; #endif } /*----------------------------------------------------------------------------- * TclXOSElapsedTime -- * System dependent interface to get the elapsed CPU and real time. * * Parameters: * o realTime - Elapsed real time, in milliseconds is returned here. * o cpuTime - Elapsed CPU time, in milliseconds is returned here. *----------------------------------------------------------------------------- */ void TclXOSElapsedTime (realTime, cpuTime) clock_t *realTime; clock_t *cpuTime; { /* * If times returns elapsed real time, this is easy. If it returns a status, * real time must be obtained in other ways. */ #ifndef TIMES_RETS_STATUS struct tms cpuTimes; *realTime = TclXOSTicksToMS (times (&cpuTimes)); *cpuTime = TclXOSTicksToMS (cpuTimes.tms_utime + cpuTimes.tms_stime); #else static struct timeval startTime = {0, 0}; struct timeval currentTime; struct tms cpuTimes; /* * If this is the first call, get base time. */ if ((startTime.tv_sec == 0) && (startTime.tv_usec == 0)) gettimeofday (&startTime, NULL); gettimeofday (¤tTime, NULL); currentTime.tv_sec = currentTime.tv_sec - startTime.tv_sec; currentTime.tv_usec = currentTime.tv_usec - startTime.tv_usec; *realTime = (currentTime.tv_sec * 1000) + (currentTime.tv_usec / 1000); times (&cpuTimes); *cpuTime = TclXOSTicksToMS (cpuTimes.tms_utime + cpuTimes.tms_stime); #endif } /*----------------------------------------------------------------------------- * TclXOSkill -- * System dependent interface to send a signal to a process. * * Parameters: * o interp - Errors returned in result. * o pid - Process id, negative process group, etc. * o signal - Signal to send. * o funcName - Command or other name to use in not available error. * Results: * TCL_OK or TCL_ERROR. *----------------------------------------------------------------------------- */ int TclXOSkill (interp, pid, signal, funcName) Tcl_Interp *interp; pid_t pid; int signal; char *funcName; { if (kill (pid, signal) < 0) { char pidStr [32]; TclX_AppendObjResult (interp, "sending signal ", (signal == 0) ? 0 : Tcl_SignalId (signal), (char *) NULL); if (pid > 0) { sprintf (pidStr, "%d", pid); TclX_AppendObjResult (interp, " to process ", pidStr, (char *) NULL); } else if (pid == 0) { sprintf (pidStr, "%d", getpgrp ()); TclX_AppendObjResult (interp, " to current process group (", pidStr, ")", (char *) NULL); } else if (pid == -1) { TclX_AppendObjResult (interp, " to all processess ", (char *) NULL); } else if (pid < -1) { sprintf (pidStr, "%d", -pid); TclX_AppendObjResult (interp, " to process group ", pidStr, (char *) NULL); } TclX_AppendObjResult (interp, " failed: ", Tcl_PosixError (interp), (char *) NULL); return TCL_ERROR; } return TCL_OK; } /*----------------------------------------------------------------------------- * TclXOSFstat -- * System dependent interface to get status information on an open file. * * Parameters: * o interp - Errors are returned in result. * o channel - Channel to get the status of. * o statBuf - Status information, made to look as much like Unix as * possible. * o ttyDev - If not NULL, a boolean indicating if the device is * associated with a tty. * Results: * TCL_OK or TCL_ERROR. *----------------------------------------------------------------------------- */ int TclXOSFstat (interp, channel, statBuf, ttyDev) Tcl_Interp *interp; Tcl_Channel channel; struct stat *statBuf; int *ttyDev; { int fileNum = ChannelToFnum (channel, 0); if (fstat (fileNum, statBuf) < 0) { TclX_AppendObjResult (interp, Tcl_GetChannelName (channel), ": ", Tcl_PosixError (interp), (char *) NULL); return TCL_ERROR; } if (ttyDev != NULL) *ttyDev = isatty (fileNum); return TCL_OK; } /*----------------------------------------------------------------------------- * TclXOSSeakable -- * System dependent interface to determine if a channel is seekable. * * Parameters: * o interp - Errors are returned in result. * o channel - Channel to get the status of. * o seekable - TRUE is return if seekable, FALSE if not. * Results: * TCL_OK or TCL_ERROR. *----------------------------------------------------------------------------- */ int TclXOSSeekable (interp, channel, seekablePtr) Tcl_Interp *interp; Tcl_Channel channel; int *seekablePtr; { struct stat statBuf; int fileNum = ChannelToFnum (channel, TCL_READABLE); if (fileNum < 0) { *seekablePtr = FALSE; return TCL_OK; } if (fstat (fileNum, &statBuf) < 0) { TclX_AppendObjResult (interp, Tcl_GetChannelName (channel), ": ", Tcl_PosixError (interp), (char *) NULL); return TCL_ERROR; } if (S_ISREG (statBuf.st_mode)) { *seekablePtr = TRUE; } else { *seekablePtr = FALSE; } return TCL_OK; } /*----------------------------------------------------------------------------- * TclXOSWalkDir -- * System dependent interface to reading the contents of a directory. The * specified directory is walked and a callback is called on each entry. * The "." and ".." entries are skipped. * * Parameters: * o interp - Interp to return errors in. * o path - Path to the directory. * o hidden - Include hidden files. Ignored on Unix. * o callback - Callback function to call on each directory entry. * It should return TCL_OK to continue processing, TCL_ERROR if an * error occured and TCL_BREAK to stop processing. The parameters are: * o interp - Interp is passed though. * o path - Normalized path to directory. * o fileName - Tcl normalized file name in directory. * o caseSensitive - Are the file names case sensitive? Always * TRUE on Unix. * o clientData - Client data that was passed. * o clientData - Client data to pass to callback. * Results: * TCL_OK if completed directory walk. TCL_BREAK if callback returned * TCL_BREAK and TCL_ERROR if an error occured. *----------------------------------------------------------------------------- */ int TclXOSWalkDir (interp, path, hidden, callback, clientData) Tcl_Interp *interp; char *path; int hidden; TclX_WalkDirProc *callback; ClientData clientData; { DIR *handle; struct dirent *entryPtr; int result = TCL_OK; handle = opendir (path); if (handle == NULL) { if (interp != NULL) TclX_AppendObjResult (interp, "open of directory \"", path, "\" failed: ", Tcl_PosixError (interp), (char *) NULL); return TCL_ERROR; } while (TRUE) { entryPtr = readdir (handle); if (entryPtr == NULL) { break; } if (entryPtr->d_name [0] == '.') { if (entryPtr->d_name [1] == '\0') continue; if ((entryPtr->d_name [1] == '.') && (entryPtr->d_name [2] == '\0')) continue; } result = (*callback) (interp, path, entryPtr->d_name, TRUE, clientData); if (!((result == TCL_OK) || (result == TCL_CONTINUE))) break; } if (result == TCL_ERROR) { closedir (handle); return TCL_ERROR; } if (closedir (handle) < 0) { if (interp != NULL) TclX_AppendObjResult (interp, "close of directory failed: ", Tcl_PosixError (interp), (char *) NULL); return TCL_ERROR; } return result; } /*----------------------------------------------------------------------------- * TclXOSGetFileSize -- * System dependent interface to get the size of an open file. * * Parameters: * o channel - Channel. * o fileSize - File size is returned here. * Results: * TCL_OK or TCL_ERROR. A POSIX error will be set. *----------------------------------------------------------------------------- */ int TclXOSGetFileSize (channel, fileSize) Tcl_Channel channel; off_t *fileSize; { struct stat statBuf; if (fstat (ChannelToFnum (channel, 0), &statBuf)) { return TCL_ERROR; } *fileSize = statBuf.st_size; return TCL_OK; } /*----------------------------------------------------------------------------- * TclXOSftruncate -- * System dependent interface to ftruncate functionality. * * Parameters: * o interp - Error messages are returned in the interpreter. * o channel - Channel to truncate. * o newSize - Size to truncate the file to. * o funcName - Command or other name to use in not available error. * Returns: * TCL_OK or TCL_ERROR. *----------------------------------------------------------------------------- */ int TclXOSftruncate (interp, channel, newSize, funcName) Tcl_Interp *interp; Tcl_Channel channel; off_t newSize; char *funcName; { #if (!defined(NO_FTRUNCATE)) || defined(HAVE_CHSIZE) int stat; #ifndef NO_FTRUNCATE stat = ftruncate (ChannelToFnum (channel, 0), newSize); #else stat = chsize (ChannelToFnum (channel, 0), newSize); #endif if (stat != 0) { TclX_AppendObjResult (interp, Tcl_GetChannelName (channel), ": ", Tcl_PosixError (interp), (char *) NULL); return TCL_ERROR; } return TCL_OK; #else return TclXNotAvailableError (interp, funcName); #endif } /*----------------------------------------------------------------------------- * TclXOSfork -- * System dependent interface to fork functionality. * * Parameters: * o interp - A format process id or errors are returned in result. * o funcName - Command or other name to use in not available error. * Results: * TCL_OK or TCL_ERROR. *----------------------------------------------------------------------------- */ int TclXOSfork (interp, funcNameObj) Tcl_Interp *interp; Tcl_Obj *funcNameObj; { pid_t pid; pid = fork (); if (pid < 0) { TclX_AppendObjResult (interp, "fork failed: ", Tcl_PosixError (interp), (char *) NULL); return TCL_ERROR; } Tcl_SetIntObj (Tcl_GetObjResult (interp), (int)pid); return TCL_OK; } /*----------------------------------------------------------------------------- * TclXOSexecl -- * System dependent interface to execl functionality. * * Parameters: * o interp - Errors are returned in result. * o path - Path to the program. * o argList - NULL terminated argument vector. * Results: * TCL_ERROR or does not return. *----------------------------------------------------------------------------- */ int TclXOSexecl (interp, path, argList) Tcl_Interp *interp; char *path; char **argList; { execvp (path, argList); /* * Can only make it here on an error. */ TclX_AppendObjResult (interp, "exec of \"", path, "\" failed: ", Tcl_PosixError (interp), (char *) NULL); return TCL_ERROR; } /*----------------------------------------------------------------------------- * TclXOSInetAtoN -- * * Convert an internet address to an "struct in_addr" representation. * * Parameters: * o interp - If not NULL, an error message is return in the result. * If NULL, no error message is generated. * o strAddress - String address to convert. * o inAddress - Converted internet address is returned here. * Returns: * TCL_OK or TCL_ERROR. *----------------------------------------------------------------------------- */ int TclXOSInetAtoN (interp, strAddress, inAddress) Tcl_Interp *interp; char *strAddress; struct in_addr *inAddress; { #ifndef NO_INET_ATON if (inet_aton (strAddress, inAddress)) return TCL_OK; #else inAddress->s_addr = inet_addr (strAddress); if (inAddress->s_addr != INADDR_NONE) return TCL_OK; #endif if (interp != NULL) { TclX_AppendObjResult (interp, "malformed address: \"", strAddress, "\"", (char *) NULL); } return TCL_ERROR; } /*----------------------------------------------------------------------------- * TclXOSgetpeername -- * System dependent interface to getpeername functionality. * * Parameters: * o interp - Errors are returned in result. * o channel - Channel associated with the socket. * o sockaddr - Pointer to sockaddr structure. * o sockaddrSize - Size of the sockaddr struct. * Results: * TCL_OK or TCL_ERROR, sets a posix error. *----------------------------------------------------------------------------- */ int TclXOSgetpeername (interp, channel, sockaddr, sockaddrSize) Tcl_Interp *interp; Tcl_Channel channel; void *sockaddr; int sockaddrSize; { if (getpeername (ChannelToFnum (channel, 0), (struct sockaddr *) sockaddr, &sockaddrSize) < 0) { TclX_AppendObjResult (interp, Tcl_GetChannelName (channel), ": ", Tcl_PosixError (interp), (char *) NULL); return TCL_ERROR; } return TCL_OK; } /*----------------------------------------------------------------------------- * TclXOSgetsockname -- * System dependent interface to getsockname functionality. * * Parameters: * o interp - Errors are returned in result. * o channel - Channel associated with the socket. * o sockaddr - Pointer to sockaddr structure. * o sockaddrSize - Size of the sockaddr struct. * Results: * TCL_OK or TCL_ERROR, sets a posix error. *----------------------------------------------------------------------------- */ int TclXOSgetsockname (interp, channel, sockaddr, sockaddrSize) Tcl_Interp *interp; Tcl_Channel channel; void *sockaddr; int sockaddrSize; { if (getsockname (ChannelToFnum (channel, 0), (struct sockaddr *) sockaddr, &sockaddrSize) < 0) { TclX_AppendObjResult (interp, Tcl_GetChannelName (channel), ": ", Tcl_PosixError (interp), (char *) NULL); return TCL_ERROR; } return TCL_OK; } /*----------------------------------------------------------------------------- * TclXOSgetsockopt -- * Get the value of a integer socket option. * * Parameters: * o interp - Errors are returned in the result. * o channel - Channel associated with the socket. * o option - Socket option to get. * o valuePtr - Integer value is returned here. * Returns: * TCL_OK or TCL_ERROR. *----------------------------------------------------------------------------- */ int TclXOSgetsockopt (interp, channel, option, valuePtr) Tcl_Interp *interp; Tcl_Channel channel; int option; int *valuePtr; { int valueLen = sizeof (*valuePtr); if (getsockopt (ChannelToFnum (channel, 0), SOL_SOCKET, option, (void*) valuePtr, &valueLen) != 0) { TclX_AppendObjResult (interp, Tcl_GetChannelName (channel), ": ", Tcl_PosixError (interp), (char *) NULL); return TCL_ERROR; } return TCL_OK; } /*----------------------------------------------------------------------------- * TclXOSsetsockopt -- * Set the value of a integer socket option. * * Parameters: * o interp - Errors are returned in the result. * o channel - Channel associated with the socket. * o option - Socket option to get. * o value - Valid integer value for the option. * Returns: * TCL_OK or TCL_ERROR. *----------------------------------------------------------------------------- */ int TclXOSsetsockopt (interp, channel, option, value) Tcl_Interp *interp; Tcl_Channel channel; int option; int value; { int valueLen = sizeof (value); if (setsockopt (ChannelToFnum (channel, 0), SOL_SOCKET, option, (void*) &value, valueLen) != 0) { TclX_AppendObjResult (interp, Tcl_GetChannelName (channel), ": ", Tcl_PosixError (interp), (char *) NULL); return TCL_ERROR; } return TCL_OK; } /*----------------------------------------------------------------------------- * TclXOSchmod -- * System dependent interface to chmod functionality. * * Parameters: * o interp - Errors returned in result. * o fileName - Name of to set the mode on. * o mode - New, unix style file access mode. * Results: * TCL_OK or TCL_ERROR. *----------------------------------------------------------------------------- */ int TclXOSchmod (interp, fileName, mode) Tcl_Interp *interp; char *fileName; int mode; { if (chmod (fileName, mode) < 0) { TclX_AppendObjResult (interp, fileName, ": ", Tcl_PosixError (interp), (char *) NULL); return TCL_ERROR; } return TCL_OK; } /*----------------------------------------------------------------------------- * TclXOSfchmod -- * System dependent interface to fchmod functionality. * * Parameters: * o interp - Errors returned in result. * o channel - Channel to set the mode on. * o mode - New, unix style file access mode. * o funcName - Command or other string to use in not available error. * Results: * TCL_OK or TCL_ERROR. *----------------------------------------------------------------------------- */ int TclXOSfchmod (interp, channel, mode, funcName) Tcl_Interp *interp; Tcl_Channel channel; int mode; char *funcName; { #ifndef NO_FCHMOD if (fchmod (ChannelToFnum (channel, 0), mode) < 0) { TclX_AppendObjResult (interp, Tcl_GetChannelName (channel), ": ", Tcl_PosixError (interp), (char *) NULL); return TCL_ERROR; } return TCL_OK; #else return TclXNotAvailableError (interp, funcName); #endif } /*----------------------------------------------------------------------------- * ConvertOwnerGroup -- * Convert the owner and group specification to ids. * * Parameters: * o interp - Pointer to the current interpreter, error messages will be * returned in the result. * o options - Option flags are: * o TCLX_CHOWN - Change file's owner. * o TCLX_CHGRP - Change file's group. * o ownerStr - String containing owner name or id. NULL if TCLX_CHOWN * not specified. * o groupStr - String containing owner name or id. NULL if TCLX_CHOWN * not specified. If NULL and TCLX_CHOWN is specified, the user's group * is used. * o ownerId - Owner id is returned here. * o groupId - Group id is returned here. * Returns: * TCL_OK or TCL_ERROR. *----------------------------------------------------------------------------- */ static int ConvertOwnerGroup (interp, options, ownerStr, groupStr, ownerId, groupId) Tcl_Interp *interp; unsigned options; char *ownerStr; char *groupStr; uid_t *ownerId; gid_t *groupId; { struct passwd *passwdPtr = NULL; struct group *groupPtr = NULL; int tmpId; if (options & TCLX_CHOWN) { passwdPtr = getpwnam (ownerStr); if (passwdPtr != NULL) { *ownerId = passwdPtr->pw_uid; } else { if (!TclX_StrToInt (ownerStr, 10, &tmpId)) goto unknownUser; /* * Check for overflow. */ *ownerId = tmpId; if ((int) (*ownerId) != tmpId) goto unknownUser; } } if (options & TCLX_CHGRP) { if (groupStr == NULL) { if (passwdPtr == NULL) { passwdPtr = getpwuid (*ownerId); if (passwdPtr == NULL) goto noGroupForUser; } *groupId = passwdPtr->pw_gid; } else { groupPtr = getgrnam (groupStr); if (groupPtr != NULL) { *groupId = groupPtr->gr_gid; } else { if (!TclX_StrToInt (groupStr, 10, &tmpId)) goto unknownGroup; /* * Check for overflow. */ *groupId = tmpId; if ((int) (*groupId) != tmpId) goto unknownGroup; } } } endpwent (); return TCL_OK; unknownUser: TclX_AppendObjResult (interp, "unknown user id: ", ownerStr, (char *) NULL); goto errorExit; noGroupForUser: TclX_AppendObjResult (interp, "can't find group for user id: ", ownerStr, (char *) NULL); goto errorExit; unknownGroup: TclX_AppendObjResult (interp, "unknown group id: ", groupStr, (char *) NULL); goto errorExit; errorExit: endpwent (); return TCL_ERROR; } /*----------------------------------------------------------------------------- * TclXOSChangeOwnGrpObj -- * Change the owner and/or group of a file by file name. * * Parameters: * o interp - Pointer to the current interpreter, error messages will be * returned in the result. * o options - Option flags are: * o TCLX_CHOWN - Change file's owner. * o TCLX_CHGRP - Change file's group. * o ownerStr - String containing owner name or id. NULL if TCLX_CHOWN * not specified. * o groupStr - String containing owner name or id. NULL if TCLX_CHOWN * not specified. If NULL and TCLX_CHOWN is specified, the user's group * is used. * o files - NULL terminated list of file names. * o funcName - Command or other name to use in not available error. * Returns: * TCL_OK or TCL_ERROR. *----------------------------------------------------------------------------- */ int TclXOSChangeOwnGrpObj (interp, options, ownerStr, groupStr, fileListObj, funcName) Tcl_Interp *interp; unsigned options; char *ownerStr; char *groupStr; Tcl_Obj *fileListObj; char *funcName; { int idx; struct stat fileStat; uid_t ownerId; gid_t groupId; char *filePath; Tcl_DString pathBuf; char *fileNameString; Tcl_Obj **filesObjv; int fileCount; if (ConvertOwnerGroup (interp, options, ownerStr, groupStr, &ownerId, &groupId) != TCL_OK) return TCL_ERROR; if (Tcl_ListObjGetElements (interp, fileListObj, &fileCount, &filesObjv) != TCL_OK) return TCL_ERROR; Tcl_DStringInit (&pathBuf); for (idx = 0; idx < fileCount; idx++) { fileNameString = Tcl_GetStringFromObj (filesObjv [idx], NULL); filePath = Tcl_TranslateFileName (interp, fileNameString, &pathBuf); if (filePath == NULL) { Tcl_DStringFree (&pathBuf); return TCL_ERROR; } /* * If we are not changing both owner and group, we need to get the * old ids. */ if ((options & (TCLX_CHOWN | TCLX_CHGRP)) != (TCLX_CHOWN | TCLX_CHGRP)) { if (stat (filePath, &fileStat) != 0) goto fileError; if ((options & TCLX_CHOWN) == 0) ownerId = fileStat.st_uid; if ((options & TCLX_CHGRP) == 0) groupId = fileStat.st_gid; } if (chown (filePath, ownerId, groupId) < 0) goto fileError; } return TCL_OK; fileError: TclX_AppendObjResult (interp, filePath, ": ", Tcl_PosixError (interp), (char *) NULL); Tcl_DStringFree (&pathBuf); return TCL_ERROR; } /*----------------------------------------------------------------------------- * TclXOSFChangeOwnGrpObj -- * Change the owner and/or group of a file by open channel. * * Parameters: * o interp - Pointer to the current interpreter, error messages will be * returned in the result. * o options - Option flags are: * o TCLX_CHOWN - Change file's owner. * o TCLX_CHGRP - Change file's group. * o ownerStr - String containing owner name or id. NULL if TCLX_CHOWN * not specified. * o groupStr - String containing owner name or id. NULL if TCLX_CHOWN * not specified. If NULL and TCLX_CHOWN is specified, the user's group * is used. * o channelIds - NULL terminated list of channel ids. * o funcName - Command or other name to use in not available error. * Returns: * TCL_OK or TCL_ERROR. *----------------------------------------------------------------------------- */ int TclXOSFChangeOwnGrpObj (interp, options, ownerStr, groupStr, channelIdsObj, funcName) Tcl_Interp *interp; unsigned options; char *ownerStr; char *groupStr; Tcl_Obj *channelIdsObj; char *funcName; { #ifndef NO_FCHOWN int idx, fnum; struct stat fileStat; uid_t ownerId; gid_t groupId; Tcl_Channel channel; Tcl_Obj **channelIdsListObj; int channelCount; if (ConvertOwnerGroup (interp, options, ownerStr, groupStr, &ownerId, &groupId) != TCL_OK) return TCL_ERROR; if (Tcl_ListObjGetElements (interp, channelIdsObj, &channelCount, &channelIdsListObj) != TCL_OK) return TCL_ERROR; for (idx = 0; idx < channelCount; idx++) { channel = TclX_GetOpenChannelObj (interp, channelIdsListObj [idx], 0); if (channel == NULL) { return TCL_ERROR; } fnum = ChannelToFnum (channel, 0); /* * If we are not changing both owner and group, we need to get the * old ids. */ if ((options & (TCLX_CHOWN | TCLX_CHGRP)) != (TCLX_CHOWN | TCLX_CHGRP)) { if (fstat (fnum, &fileStat) != 0) goto fileError; if ((options & TCLX_CHOWN) == 0) ownerId = fileStat.st_uid; if ((options & TCLX_CHGRP) == 0) groupId = fileStat.st_gid; } if (fchown (fnum, ownerId, groupId) < 0) goto fileError; } return TCL_OK; fileError: TclX_AppendObjResult (interp, channelIdsListObj [idx], ": ", Tcl_PosixError (interp), (char *) NULL); return TCL_ERROR; #else return TclXNotAvailableError (interp, funcName); #endif } /*----------------------------------------------------------------------------- * TclXOSFChangeOwnGrp -- * Change the owner and/or group of a file by open channel. * * Parameters: * o interp - Pointer to the current interpreter, error messages will be * returned in the result. * o options - Option flags are: * o TCLX_CHOWN - Change file's owner. * o TCLX_CHGRP - Change file's group. * o ownerStr - String containing owner name or id. NULL if TCLX_CHOWN * not specified. * o groupStr - String containing owner name or id. NULL if TCLX_CHOWN * not specified. If NULL and TCLX_CHOWN is specified, the user's group * is used. * o channelIds - NULL terminated list of channel ids. * o funcName - Command or other name to use in not available error. * Returns: * TCL_OK or TCL_ERROR. *----------------------------------------------------------------------------- */ int TclXOSFChangeOwnGrp (interp, options, ownerStr, groupStr, channelIds, funcName) Tcl_Interp *interp; unsigned options; char *ownerStr; char *groupStr; char **channelIds; char *funcName; { #ifndef NO_FCHOWN int idx, fnum; struct stat fileStat; uid_t ownerId; gid_t groupId; Tcl_Channel channel; if (ConvertOwnerGroup (interp, options, ownerStr, groupStr, &ownerId, &groupId) != TCL_OK) return TCL_ERROR; for (idx = 0; channelIds [idx] != NULL; idx++) { channel = TclX_GetOpenChannel (interp, channelIds [idx], 0); if (channel == NULL) return TCL_ERROR; fnum = ChannelToFnum (channel, 0); /* * If we are not changing both owner and group, we need to get the * old ids. */ if ((options & (TCLX_CHOWN | TCLX_CHGRP)) != (TCLX_CHOWN | TCLX_CHGRP)) { if (fstat (fnum, &fileStat) != 0) goto fileError; if ((options & TCLX_CHOWN) == 0) ownerId = fileStat.st_uid; if ((options & TCLX_CHGRP) == 0) groupId = fileStat.st_gid; } if (fchown (fnum, ownerId, groupId) < 0) goto fileError; } return TCL_OK; fileError: TclX_AppendObjResult (interp, channelIds [idx], ": ", Tcl_PosixError (interp), (char *) NULL); return TCL_ERROR; #else return TclXNotAvailableError (interp, funcName); #endif } /*----------------------------------------------------------------------------- * TclXOSGetSelectFnum -- * Convert a channel its read or write file numbers for use in select. * * Parameters: * o interp - Pointer to the current interpreter, error messages will be * returned in the result. * o channel - Channel to get the numbers for. * o direction - TCL_READABLE or TCL_WRITABLE. * o fnumPtr - The file number for the direction is returned here. * Returns: * TCL_OK or TCL_ERROR. *----------------------------------------------------------------------------- */ int TclXOSGetSelectFnum (interp, channel, direction, fnumPtr) Tcl_Interp *interp; Tcl_Channel channel; int direction; int *fnumPtr; { ClientData handle; if (Tcl_GetChannelHandle (channel, direction, &handle) != TCL_OK) { TclX_AppendObjResult (interp, "channel ", Tcl_GetChannelName (channel), " was not open for requested access", (char *) NULL); return TCL_ERROR; } *fnumPtr = (int) handle; return TCL_OK; } /*----------------------------------------------------------------------------- * TclXOSHaveFlock -- * System dependent interface to determine if file locking is available. * Returns: * TRUE if file locking is available, FALSE if it is not. *----------------------------------------------------------------------------- */ int TclXOSHaveFlock () { #ifdef F_SETLKW return TRUE; #else return FALSE; #endif } /*----------------------------------------------------------------------------- * TclXOSFlock -- * System dependent interface to locking a file. * * Parameters: * o interp - Pointer to the current interpreter, error messages will be * returned in the result. * o lockInfoPtr - Lock specification, gotLock will be initialized. * Returns: * TCL_OK or TCL_ERROR. *----------------------------------------------------------------------------- */ int TclXOSFlock (interp, lockInfoPtr) Tcl_Interp *interp; TclX_FlockInfo *lockInfoPtr; { #ifdef F_SETLKW int fnum, stat; struct flock flockInfo; flockInfo.l_start = lockInfoPtr->start; flockInfo.l_len = lockInfoPtr->len; flockInfo.l_type = (lockInfoPtr->access == TCL_WRITABLE) ? F_WRLCK : F_RDLCK; flockInfo.l_whence = lockInfoPtr->whence; fnum = ChannelToFnum (lockInfoPtr->channel, lockInfoPtr->access); stat = fcntl (fnum, lockInfoPtr->block ? F_SETLKW : F_SETLK, &flockInfo); /* * Handle status from non-blocking lock. */ if ((stat < 0) && (!lockInfoPtr->block) && ((errno == EACCES) || (errno == EAGAIN))) { lockInfoPtr->gotLock = FALSE; return TCL_OK; } if (stat < 0) { lockInfoPtr->gotLock = FALSE; TclX_AppendObjResult (interp, "lock of \"", Tcl_GetChannelName (lockInfoPtr->channel), "\" failed: ", Tcl_PosixError (interp), (char *) NULL); return TCL_ERROR; } lockInfoPtr->gotLock = TRUE; return TCL_OK; #else return TclXNotAvailableError (interp, "file locking"); #endif } /*----------------------------------------------------------------------------- * TclXOSFunlock -- * System dependent interface to unlocking a file. * * Parameters: * o interp - Pointer to the current interpreter, error messages will be * returned in the result. * o lockInfoPtr - Lock specification. * Returns: * TCL_OK or TCL_ERROR. *----------------------------------------------------------------------------- */ int TclXOSFunlock (interp, lockInfoPtr) Tcl_Interp *interp; TclX_FlockInfo *lockInfoPtr; { #ifdef F_SETLKW int fnum, stat; struct flock flockInfo; flockInfo.l_start = lockInfoPtr->start; flockInfo.l_len = lockInfoPtr->len; flockInfo.l_type = F_UNLCK; flockInfo.l_whence = lockInfoPtr->whence; fnum = ChannelToFnum (lockInfoPtr->channel, lockInfoPtr->access); stat = fcntl (fnum, F_SETLK, &flockInfo); if (stat < 0) { TclX_AppendObjResult (interp, "lock of \"", Tcl_GetChannelName (lockInfoPtr->channel), "\" failed: ", Tcl_PosixError (interp)); return TCL_ERROR; } return TCL_OK; #else return TclXNotAvailableError (interp, "file locking"); #endif } /*----------------------------------------------------------------------------- * TclXOSGetAppend -- * System dependent interface determine if a channel is in force append mode. * * Parameters: * o interp - Pointer to the current interpreter, error messages will be * returned in the result. * o channel - Channel to get mode for. The write file is used. * o valuePtr - TRUE is returned if in append mode, FALSE if not. * Returns: * TCL_OK or TCL_ERROR. *----------------------------------------------------------------------------- */ int TclXOSGetAppend (interp, channel, valuePtr) Tcl_Interp *interp; Tcl_Channel channel; int *valuePtr; { int fnum, mode; fnum = ChannelToFnum (channel, TCL_WRITABLE); if (fnum < 0) { TclX_AppendObjResult (interp, Tcl_GetChannelName (channel), " is not open for write access", (char *) NULL); return TCL_ERROR; } mode = fcntl (fnum, F_GETFL, 0); if (mode == -1) goto posixError; *valuePtr = ((mode & O_APPEND) != 0); return TCL_OK; posixError: TclX_AppendObjResult (interp, Tcl_GetChannelName (channel), ": ", Tcl_PosixError (interp), (char *) NULL); return TCL_ERROR; } /*----------------------------------------------------------------------------- * TclXOSSetAppend -- * System dependent interface set force append mode on a channel. * * Parameters: * o interp - Pointer to the current interpreter, error messages will be * returned in the result. * o channel - Channel to get mode for. The write file is used. * o value - TRUE to enable, FALSE to disable. * Returns: * TCL_OK or TCL_ERROR. *----------------------------------------------------------------------------- */ int TclXOSSetAppend (interp, channel, value) Tcl_Interp *interp; Tcl_Channel channel; int value; { int fnum, mode; fnum = ChannelToFnum (channel, TCL_WRITABLE); if (fnum < 0) { TclX_AppendObjResult (interp, Tcl_GetChannelName (channel), " is not open for write access", (char *) NULL); return TCL_ERROR; } mode = fcntl (fnum, F_GETFL, 0); if (mode == -1) goto posixError; mode = (mode & ~O_APPEND) | (value ? O_APPEND : 0); if (fcntl (fnum, F_SETFL, mode) == -1) goto posixError; return TCL_OK; posixError: TclX_AppendObjResult (interp, Tcl_GetChannelName (channel), ": ", Tcl_PosixError (interp), (char *) NULL); return TCL_ERROR; } /*----------------------------------------------------------------------------- * TclXOSGetCloseOnExec -- * System dependent interface determine if a channel has close-on-exec set. * * Parameters: * o interp - Pointer to the current interpreter, error messages will be * returned in the result. * o channel - Channel to get mode for. The write file is used. * o valuePtr - TRUE is close-on-exec, FALSE if not. * Returns: * TCL_OK or TCL_ERROR. *----------------------------------------------------------------------------- */ int TclXOSGetCloseOnExec (interp, channel, valuePtr) Tcl_Interp *interp; Tcl_Channel channel; int *valuePtr; { int readFnum; int writeFnum; int readMode = 0; int writeMode = 0; readFnum = ChannelToFnum (channel, TCL_READABLE); writeFnum = ChannelToFnum (channel, TCL_WRITABLE); if (readFnum >= 0) { readMode = fcntl (readFnum, F_GETFD, 0); if (readMode == -1) goto posixError; } if (writeFnum >= 0) { writeMode = fcntl (writeFnum, F_GETFD, 0); if (writeMode == -1) goto posixError; } /* * It's an error if both files are not the same. This could only happen * if they were set outside of TclX. While this maybe overly strict, * this may prevent bugs. */ if ((readFnum >= 0) && (writeFnum >= 0) && ((readMode & 1) != (writeMode & 1))) { TclX_AppendObjResult (interp, Tcl_GetChannelName (channel), ": read file of channel has close-on-exec ", (readMode & 1) ? "on" : "off", " and write file has it ", (writeMode & 1) ? "on" : "off", "; don't know how to get attribute for a ", "channel configure this way", (char *) NULL); return TCL_ERROR; } *valuePtr = (readFnum >= 0) ? (readMode & 1) : (writeMode & 1); return TCL_OK; posixError: TclX_AppendObjResult (interp, Tcl_GetChannelName (channel), ": ", Tcl_PosixError (interp), (char *) NULL); return TCL_ERROR; } /*----------------------------------------------------------------------------- * TclXOSSetCloseOnExec -- * System dependent interface set close-on-exec on a channel. * * Parameters: * o interp - Pointer to the current interpreter, error messages will be * returned in the result. * o channel - Channel to get mode for. The write file is used. * o value - TRUE to enable, FALSE to disable. * Returns: * TCL_OK or TCL_ERROR. *----------------------------------------------------------------------------- */ int TclXOSSetCloseOnExec (interp, channel, value) Tcl_Interp *interp; Tcl_Channel channel; int value; { int readFnum, writeFnum; readFnum = ChannelToFnum (channel, TCL_READABLE); writeFnum = ChannelToFnum (channel, TCL_WRITABLE); if (readFnum > 0) { if (fcntl (readFnum, F_SETFD, value ? 1 : 0) == -1) goto posixError; } if ((writeFnum > 0) && (readFnum != writeFnum)) { if (fcntl (writeFnum, F_SETFD, value ? 1 : 0) == -1) goto posixError; } return TCL_OK; posixError: TclX_AppendObjResult (interp, Tcl_GetChannelName (channel), ": ", Tcl_PosixError (interp), (char *) NULL); return TCL_ERROR; } tclx8.4-8.4.1.orig/unix/tclXunixId.c0000644000000000000000000004533612046313167014015 0ustar /* * tclXunixId.c -- * * Tcl commands to access getuid, setuid, getgid, setgid and friends on Unix. *----------------------------------------------------------------------------- * Copyright 1991-1999 Karl Lehenbauer and Mark Diekhans. * * Permission to use, copy, modify, and distribute this software and its * documentation for any purpose and without fee is hereby granted, provided * that the above copyright notice appear in all copies. Karl Lehenbauer and * Mark Diekhans make no representations about the suitability of this * software for any purpose. It is provided "as is" without express or * implied warranty. *----------------------------------------------------------------------------- * $Id: tclXunixId.c,v 8.1 2001/10/24 23:31:50 hobbs Exp $ *----------------------------------------------------------------------------- */ #include "tclExtdInt.h" /* * Actually configured number of groups (from sysconf if we have it). */ #ifndef NO_SYSCONF static int confNGroups = -1; #else #ifndef NGROUPS # ifdef NGROUPS_MAX # define NGROUPS NGROUPS_MAX # else # define NGROUPS 32 # endif #endif static int confNGroups = NGROUPS; #endif /* * Prototypes of internal functions. */ static int UseridToUsernameResult _ANSI_ARGS_((Tcl_Interp *interp, int userId)); static int UsernameToUseridResult _ANSI_ARGS_((Tcl_Interp *interp, char *userName)); static int GroupidToGroupnameResult _ANSI_ARGS_((Tcl_Interp *interp, int groupId)); static int GroupnameToGroupidResult _ANSI_ARGS_((Tcl_Interp *interp, char *groupName)); static int IdConvert _ANSI_ARGS_((Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int IdEffective _ANSI_ARGS_((Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int IdProcess _ANSI_ARGS_((Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int IdGroupids _ANSI_ARGS_((Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[], int symbolic)); static int IdHost _ANSI_ARGS_((Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int GetSetWrongArgs _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *CONST objv[])); static int IdUser _ANSI_ARGS_((Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int IdUserId _ANSI_ARGS_((Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int IdGroup _ANSI_ARGS_((Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int IdGroupId _ANSI_ARGS_((Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int TclX_IdObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); /*----------------------------------------------------------------------------- * TclX_IdObjCmd -- * Implements the TclX id command on Unix. * * id user ?name? * id convert user * * id userid ?uid? * id convert userid * * id group ?name? * id convert group * * id groupid ?gid? * id convert groupid * * id groupids * * id host * * id process * id process parent * id process group * id process group set * * id effective user * id effective userid * * id effective group * id effective groupid * * Results: * Standard TCL results, may return the UNIX system error message. * *----------------------------------------------------------------------------- */ static int UseridToUsernameResult (interp, userId) Tcl_Interp *interp; int userId; { uid_t uid = (uid_t) userId; struct passwd *pw = getpwuid (userId); Tcl_Obj *resultObj = Tcl_GetObjResult (interp); char userIdString[16]; if ((pw == NULL) || ((int) uid != userId)) { sprintf (userIdString, "%d", uid); Tcl_AppendStringsToObj (resultObj, "unknown user id: ", userIdString, NULL); endpwent (); return TCL_ERROR; } Tcl_AppendToObj (resultObj, pw->pw_name, -1); endpwent (); return TCL_OK; } static int UsernameToUseridResult (interp, userName) Tcl_Interp *interp; char *userName; { struct passwd *pw = getpwnam (userName); Tcl_Obj *resultObj = Tcl_GetObjResult (interp); if (pw == NULL) { Tcl_AppendStringsToObj (resultObj, "unknown user id: ", userName, (char *) NULL); endpwent (); return TCL_ERROR; } Tcl_SetObjResult (interp, Tcl_NewIntObj (pw->pw_uid)); endpwent (); return TCL_OK; } static int GroupidToGroupnameResult (interp, groupId) Tcl_Interp *interp; int groupId; { gid_t gid = (gid_t) groupId; struct group *grp = getgrgid (groupId); Tcl_Obj *resultObj = Tcl_GetObjResult (interp); char groupIdString[16]; sprintf (groupIdString, "%d", gid); if ((grp == NULL) || ((int) gid != groupId)) { Tcl_AppendStringsToObj (resultObj, "unknown group id: ", groupIdString, (char *)NULL); endgrent (); return TCL_ERROR; } Tcl_AppendToObj (resultObj, grp->gr_name, -1); endgrent (); return TCL_OK; } static int GroupnameToGroupidResult (interp, groupName) Tcl_Interp *interp; char *groupName; { struct group *grp = getgrnam (groupName); Tcl_Obj *resultObj = Tcl_GetObjResult (interp); if (grp == NULL) { Tcl_AppendStringsToObj (resultObj, "unknown group id: ", groupName, (char *) NULL); return TCL_ERROR; } Tcl_SetIntObj (resultObj, grp->gr_gid); return TCL_OK; } /* * id convert type value */ static int IdConvert (interp, objc, objv) Tcl_Interp *interp; int objc; Tcl_Obj *CONST objv[]; { long uid; long gid; char *subCommand; char *valueString; if (objc != 4) return TclX_WrongArgs (interp, objv [0], "convert type value"); subCommand = Tcl_GetStringFromObj (objv[2], NULL); valueString = Tcl_GetStringFromObj (objv[3], NULL); if (STREQU (subCommand, "user")) return UsernameToUseridResult (interp, valueString); if (STREQU (subCommand, "userid")) { if (Tcl_GetLongFromObj (interp, objv[3], &uid) != TCL_OK) return TCL_ERROR; return UseridToUsernameResult (interp, uid); } if (STREQU (subCommand, "group")) return GroupnameToGroupidResult (interp, valueString); if (STREQU (subCommand, "groupid")) { if (Tcl_GetLongFromObj (interp, objv[3], &gid) != TCL_OK) return TCL_ERROR; return GroupidToGroupnameResult (interp, gid); } TclX_AppendObjResult (interp, "third arg must be \"user\", \"userid\", ", "\"group\" or \"groupid\", got \"", subCommand, "\"", (char *) NULL); return TCL_ERROR; } /* * id effective type */ static int IdEffective (interp, objc, objv) Tcl_Interp *interp; int objc; Tcl_Obj *CONST objv[]; { char *subCommand; if (objc != 3) return TclX_WrongArgs (interp, objv [0], "effective type"); subCommand = Tcl_GetStringFromObj (objv[2], NULL); if (STREQU (subCommand, "user")) return UseridToUsernameResult (interp, geteuid ()); if (STREQU (subCommand, "userid")) { Tcl_SetObjResult (interp, Tcl_NewIntObj (geteuid ())); return TCL_OK; } if (STREQU (subCommand, "group")) return GroupidToGroupnameResult (interp, getegid ()); if (STREQU (subCommand, "groupid")) { Tcl_SetObjResult (interp, Tcl_NewIntObj (getegid ())); return TCL_OK; } TclX_AppendObjResult (interp, "third arg must be \"user\", \"userid\", ", "\"group\" or \"groupid\", got \"", subCommand, "\"", (char *) NULL); return TCL_ERROR; } /* * id process ?parent|group? ?set? */ static int IdProcess (interp, objc, objv) Tcl_Interp *interp; int objc; Tcl_Obj *CONST objv[]; { pid_t pid; char *subCommand; char *trailerCommand; if (objc > 4) return TclX_WrongArgs (interp, objv [0], "process ?parent|group? ?set?"); if (objc == 2) { Tcl_SetObjResult (interp, Tcl_NewIntObj (getpid ())); return TCL_OK; } subCommand = Tcl_GetStringFromObj (objv[2], NULL); if (STREQU (subCommand, "parent")) { if (objc != 3) return TclX_WrongArgs (interp, objv [0], " process parent"); Tcl_SetObjResult (interp, Tcl_NewIntObj (getppid ())); return TCL_OK; } if (STREQU (subCommand, "group")) { if (objc == 3) { Tcl_SetObjResult (interp, Tcl_NewIntObj (getpgrp ())); return TCL_OK; } trailerCommand = Tcl_GetStringFromObj (objv[3], NULL); if ((objc != 4) || !STREQU (trailerCommand, "set")) return TclX_WrongArgs (interp, objv [0], " process group ?set?"); if (Tcl_IsSafe (interp)) { TclX_AppendObjResult (interp, "can't set process group from a ", "safe interpeter", (char *) NULL); return TCL_ERROR; } #ifndef NO_SETPGID pid = getpid (); setpgid (pid, pid); #else setpgrp (); #endif return TCL_OK; } TclX_AppendObjResult (interp, "expected one of \"parent\" or \"group\" ", "got\"", subCommand, "\"", (char *) NULL); return TCL_ERROR; } /* * id groupids * id groups */ static int IdGroupids (interp, objc, objv, symbolic) Tcl_Interp *interp; int objc; Tcl_Obj *CONST objv[]; int symbolic; { #ifndef NO_GETGROUPS gid_t *groups; int nGroups, groupIndex; struct group *grp; Tcl_Obj *resultObj = Tcl_GetObjResult (interp); Tcl_Obj *newObj; if (objc != 2) return TclX_WrongArgs (interp, objv [0], "arg"); #ifndef NO_SYSCONF if (confNGroups < 0) confNGroups = sysconf (_SC_NGROUPS_MAX); #endif groups = (gid_t *) ckalloc (confNGroups * sizeof (gid_t)); nGroups = getgroups (confNGroups, groups); if (nGroups < 0) { Tcl_AppendStringsToObj (Tcl_GetObjResult (interp), Tcl_PosixError (interp), (char *) NULL); ckfree ((char *) groups); return TCL_ERROR; } for (groupIndex = 0; groupIndex < nGroups; groupIndex++) { if (symbolic) { int groupId = groups [groupIndex]; grp = getgrgid (groupId); if (grp == NULL) { char groupIdString[16]; sprintf (groupIdString, "%d", groupId); Tcl_AppendStringsToObj (resultObj, "unknown group id: ", groupIdString, (char *)NULL); endgrent (); return TCL_ERROR; } newObj = Tcl_NewStringObj (grp->gr_name, -1); Tcl_ListObjAppendElement (interp, resultObj, newObj); } else { newObj = Tcl_NewIntObj(groups[groupIndex]); Tcl_ListObjAppendElement (interp, resultObj, newObj); } } if (symbolic) endgrent (); ckfree ((char *) groups); return TCL_OK; #else TclX_AppendObjResult (interp, "group id lists unavailable on this system ", "(no getgroups function)", (char *) NULL); return TCL_ERROR; #endif } /* * id host */ static int IdHost (interp, objc, objv) Tcl_Interp *interp; int objc; Tcl_Obj *CONST objv[]; { #ifndef NO_GETHOSTNAME #ifndef MAXHOSTNAMELEN # define MAXHOSTNAMELEN 256 #endif char hostNameBuf[MAXHOSTNAMELEN]; if (objc != 2) return TclX_WrongArgs (interp, objv [0], "host"); if (gethostname (hostNameBuf, MAXHOSTNAMELEN) < 0) { TclX_AppendObjResult (interp, Tcl_PosixError (interp), (char *) NULL); return TCL_ERROR; } hostNameBuf[MAXHOSTNAMELEN-1] = '\0'; Tcl_SetObjResult (interp, Tcl_NewStringObj (hostNameBuf, -1)); return TCL_OK; #else TclX_AppendObjResult (interp, "host name unavailable on this system ", "(no gethostname function)", (char *) NULL); return TCL_ERROR; #endif } /* * Return error when a get set function has too many args (2 or 3 expected). */ static int GetSetWrongArgs (interp, objv) Tcl_Interp *interp; Tcl_Obj *CONST objv[]; { return TclX_WrongArgs (interp, objv [0], "arg ?value?"); } /* * id user */ static int IdUser (interp, objc, objv) Tcl_Interp *interp; int objc; Tcl_Obj *CONST objv[]; { struct passwd *pw; char *user; if (objc > 3) return GetSetWrongArgs (interp, objv); if (objc == 2) { return UseridToUsernameResult (interp, getuid ()); } user = Tcl_GetStringFromObj (objv[2], NULL); pw = getpwnam (user); if (pw == NULL) { TclX_AppendObjResult (interp, "user \"",user, "\" does not exist", (char *) NULL); goto errorExit; } if (setuid (pw->pw_uid) < 0) { TclX_AppendObjResult (interp, Tcl_PosixError (interp), (char *) NULL); goto errorExit; } endpwent (); return TCL_OK; errorExit: endpwent (); return TCL_ERROR; } /* * id userid */ static int IdUserId (interp, objc, objv) Tcl_Interp *interp; int objc; Tcl_Obj *CONST objv[]; { int uid; if (objc > 3) return GetSetWrongArgs (interp, objv); if (objc == 2) { Tcl_SetObjResult (interp, Tcl_NewIntObj (getuid())); return TCL_OK; } if (Tcl_GetIntFromObj (interp, objv[2], &uid) != TCL_OK) return TCL_ERROR; if (setuid ((uid_t) uid) < 0) { TclX_AppendObjResult (interp, Tcl_PosixError (interp), (char *) NULL); return TCL_ERROR; } return TCL_OK; } /* * id group */ static int IdGroup (interp, objc, objv) Tcl_Interp *interp; int objc; Tcl_Obj *CONST objv[]; { struct group *grp; char *groupName; if (objc > 3) return GetSetWrongArgs (interp, objv); if (objc == 2) { return GroupidToGroupnameResult (interp, getgid ()); } groupName = Tcl_GetStringFromObj (objv[2], NULL); grp = getgrnam (groupName); if (grp == NULL) { TclX_AppendObjResult (interp, "group \"", groupName, "\" does not exist", (char *) NULL); goto errorExit; } if (setgid (grp->gr_gid) < 0) { TclX_AppendObjResult (interp, Tcl_PosixError (interp), (char *) NULL); goto errorExit; } endgrent (); return TCL_OK; errorExit: endgrent (); return TCL_ERROR; } /* * id groupid */ static int IdGroupId (interp, objc, objv) Tcl_Interp *interp; int objc; Tcl_Obj *CONST objv[]; { int gid; if (objc > 3) return GetSetWrongArgs (interp, objv); if (objc == 2) { Tcl_SetIntObj (Tcl_GetObjResult (interp), getgid()); return TCL_OK; } if (Tcl_GetIntFromObj (interp, objv[2], &gid) != TCL_OK) return TCL_ERROR; if (setgid ((gid_t) gid) < 0) { TclX_AppendObjResult (interp, Tcl_PosixError (interp), (char *) NULL); return TCL_ERROR; } return TCL_OK; } static int TclX_IdObjCmd (clientData, interp, objc, objv) ClientData clientData; Tcl_Interp *interp; int objc; Tcl_Obj *CONST objv[]; { char *subCommand; if (objc < 2) return TclX_WrongArgs (interp, objv [0], "arg ?arg...?"); subCommand = Tcl_GetStringFromObj (objv [1], NULL); /* * If the first argument is "convert", handle the conversion. */ if (STREQU (subCommand, "convert")) { return IdConvert (interp, objc, objv); } /* * If the first argument is "effective", return the effective user ID, * name, group ID or name. */ if (STREQU (subCommand, "effective")) { return IdEffective (interp, objc, objv); } /* * If the first argument is "process", return the process ID, parent's * process ID, process group or set the process group depending on args. */ if (STREQU (subCommand, "process")) { return IdProcess (interp, objc, objv); } /* * Handle getting list of groups the user is a member of. */ if (STREQU (subCommand, "groups")) { return IdGroupids (interp, objc, objv, TRUE); } if (STREQU (subCommand, "groupids")) { return IdGroupids (interp, objc, objv, FALSE); } /* * Handle returning the host name if its available. */ if (STREQU (subCommand, "host")) { return IdHost (interp, objc, objv); } /* * Handle setting or returning the user ID or group ID (by name or number). */ if (STREQU (subCommand, "user")) { return IdUser (interp, objc, objv); } if (STREQU (subCommand, "userid")) { return IdUserId (interp, objc, objv); } if (STREQU (subCommand, "group")) { return IdGroup (interp, objc, objv); } if (STREQU (subCommand, "groupid")) { return IdGroupId (interp, objc, objv); } TclX_AppendObjResult (interp, "second arg must be one of \"convert\", ", "\"effective\", \"process\", ", "\"user\", \"userid\", \"group\", \"groupid\", ", "\"groups\", \"groupids\", ", "or \"host\"", (char *) NULL); return TCL_ERROR; } /*----------------------------------------------------------------------------- * TclX_IdInit -- * Initialize the id command. *----------------------------------------------------------------------------- */ void TclX_IdInit (interp) Tcl_Interp *interp; { Tcl_CreateObjCommand (interp, "id", TclX_IdObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc*) NULL); } tclx8.4-8.4.1.orig/unix/tclXunixCmds.c0000644000000000000000000000734112046313167014341 0ustar /* * tclXunixCmds.c -- * * Tcl commands to access unix system calls that are not portable to other * platforms. *----------------------------------------------------------------------------- * Copyright 1991-1999 Karl Lehenbauer and Mark Diekhans. * * Permission to use, copy, modify, and distribute this software and its * documentation for any purpose and without fee is hereby granted, provided * that the above copyright notice appear in all copies. Karl Lehenbauer and * Mark Diekhans make no representations about the suitability of this * software for any purpose. It is provided "as is" without express or * implied warranty. *----------------------------------------------------------------------------- * $Id: tclXunixCmds.c,v 8.1 2001/10/24 23:31:50 hobbs Exp $ *----------------------------------------------------------------------------- */ #include "tclExtdInt.h" static int TclX_ChrootObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int TclX_TimesObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); /*----------------------------------------------------------------------------- * TclX_ChrootObjCmd -- * Implements the TCL chroot command: * chroot path * * Results: * Standard TCL results, may return the UNIX system error message. * *----------------------------------------------------------------------------- */ static int TclX_ChrootObjCmd (clientData, interp, objc, objv) ClientData clientData; Tcl_Interp *interp; int objc; Tcl_Obj *CONST objv[]; { char *chrootString; int chrootStrLen; if (objc != 2) return TclX_WrongArgs (interp, objv [0], "path"); chrootString = Tcl_GetStringFromObj (objv [1], &chrootStrLen); if (chroot (chrootString) < 0) { TclX_AppendObjResult (interp, "changing root to \"", chrootString, "\" failed: ", Tcl_PosixError (interp), (char *) NULL); return TCL_ERROR; } return TCL_OK; } /*----------------------------------------------------------------------------- * TclX_TimesObjCmd -- * Implements the TCL times command: * times * * Results: * Standard TCL results. * *----------------------------------------------------------------------------- */ static int TclX_TimesObjCmd (clientData, interp, objc, objv) ClientData clientData; Tcl_Interp *interp; int objc; Tcl_Obj *CONST objv[]; { struct tms tm; char timesBuf [48]; if (objc != 1) return TclX_WrongArgs (interp, objv [0], ""); times (&tm); sprintf (timesBuf, "%ld %ld %ld %ld", (long) TclXOSTicksToMS (tm.tms_utime), (long) TclXOSTicksToMS (tm.tms_stime), (long) TclXOSTicksToMS (tm.tms_cutime), (long) TclXOSTicksToMS (tm.tms_cstime)); Tcl_SetStringObj (Tcl_GetObjResult (interp), timesBuf, -1); return TCL_OK; } /*----------------------------------------------------------------------------- * TclX_PlatformCmdsInit -- * Initialize the platform-specific commands. *----------------------------------------------------------------------------- */ void TclX_PlatformCmdsInit (interp) Tcl_Interp *interp; { Tcl_CreateObjCommand (interp, "chroot", TclX_ChrootObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateObjCommand (interp, "times", TclX_TimesObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc*) NULL); } tclx8.4-8.4.1.orig/unix/tclXunixPort.h0000644000000000000000000000540012046313167014376 0ustar /* * tclXunixPort.h * * Portability include file for Unix systems. *----------------------------------------------------------------------------- * Copyright 1996-1999 Karl Lehenbauer and Mark Diekhans. * * Permission to use, copy, modify, and distribute this software and its * documentation for any purpose and without fee is hereby granted, provided * that the above copyright notice appear in all copies. Karl Lehenbauer and * Mark Diekhans make no representations about the suitability of this * software for any purpose. It is provided "as is" without express or * implied warranty. *----------------------------------------------------------------------------- * $Id: tclXunixPort.h,v 8.5 2007/02/28 00:14:09 hobbs Exp $ *----------------------------------------------------------------------------- */ #ifndef TCLXUNIXPORT_H #define TCLXUNIXPORT_H #include #include #ifdef NO_LIMITS_H # include #else # include #endif #include #include #include #ifndef __xlC__ /* AIX xlc */ extern int h_errno; #endif #ifdef __APPLE__ # undef panic #endif /* * Included the tcl file tclUnixPort.h after other system files, as it checks * if certain things are defined. */ #include "tclUnixPort.h" /* * Define O_ACCMODE if does not define it. */ #ifndef O_ACCMODE # define O_ACCMODE (O_RDONLY|O_WRONLY|O_RDWR) #endif /* * Make sure we have both O_NONBLOCK and O_NDELAY defined. */ #ifndef O_NONBLOCK # define O_NONBLOCK O_NDELAY #endif #ifndef O_NDELAY # define O_NDELAY O_NONBLOCK #endif /* * Make sure CLK_TCK is defined. */ #ifndef CLK_TCK # ifdef HZ # define CLK_TCK HZ # else # define CLK_TCK 60 # endif #endif /* * Defines needed for socket code. ((unsigned long) -1) is not correct * for 64-bit systems, use 0XFFFFFFFFUL. [Bug 1242825] */ #ifndef INADDR_NONE # define INADDR_NONE 0xFFFFFFFFUL #endif /* * BSD functions. */ #ifdef NO_BCOPY # define bcopy(from, to, length) memmove((to), (from), (length)) #endif #ifdef NO_BZERO # define bzero(to,length) memset(to,'\0',length) #endif /* * Math defines. */ #ifndef MAXDOUBLE # define MAXDOUBLE HUGE_VAL #endif /* * Define C lib prototypes that are either missing or being emulated by * the compat library. */ #if defined(NO_RANDOM) || defined(NO_RANDOM_PROTO) extern long random (); #endif /* * If sigaction is available, check for restartable signals. */ #ifndef NO_SIGACTION # ifndef SA_RESTART # define NO_SIG_RESTART # endif #else # define NO_SIG_RESTART #endif /* * Define a macro to call wait pid. We don't use Tcl_WaitPid on Unix because * it delays signals. */ #define TCLX_WAITPID(pid, status, options) waitpid (pid, status, options) #endif tclx8.4-8.4.1.orig/unix/tclXunixTest.c0000644000000000000000000000520712046313167014371 0ustar /* * tclXunixTest.c -- * * Tcl_AppInit and main functions for the Extended Tcl test program on Unix. * *----------------------------------------------------------------------------- * Copyright 1991-1999 Karl Lehenbauer and Mark Diekhans. * * Permission to use, copy, modify, and distribute this software and its * documentation for any purpose and without fee is hereby granted, provided * that the above copyright notice appear in all copies. Karl Lehenbauer and * Mark Diekhans make no representations about the suitability of this * software for any purpose. It is provided "as is" without express or * implied warranty. *----------------------------------------------------------------------------- * $Id: tclXunixTest.c,v 8.1 2001/10/24 23:31:50 hobbs Exp $ *----------------------------------------------------------------------------- */ #include "tclExtdInt.h" extern int Tcltest_Init _ANSI_ARGS_((Tcl_Interp *interp)); extern int Tclxtest_Init _ANSI_ARGS_((Tcl_Interp *interp)); /* * The following variable is a special hack that insures the tcl * version of matherr() is used when linking against shared libraries. * Even if matherr is not used on this system, there is a dummy version * in libtcl. */ extern int matherr (); int (*tclDummyMathPtr)() = matherr; /*----------------------------------------------------------------------------- * main -- * This is the main program for the application. *----------------------------------------------------------------------------- */ int main (argc, argv) int argc; char **argv; { TclX_Main (argc, argv, Tcl_AppInit); return 0; /* Needed only to prevent compiler warning. */ } /*----------------------------------------------------------------------------- * Tcl_AppInit -- * Initialize TclX test application. * * Results: * Returns a standard Tcl completion code, and leaves an error message in * interp result if an error occurs. *----------------------------------------------------------------------------- */ int Tcl_AppInit (interp) Tcl_Interp *interp; { if (Tcl_Init (interp) == TCL_ERROR) { return TCL_ERROR; } if (Tclx_Init (interp) == TCL_ERROR) { return TCL_ERROR; } Tcl_StaticPackage (interp, "Tclx", Tclx_Init, Tclx_SafeInit); if (Tcltest_Init (interp) == TCL_ERROR) { return TCL_ERROR; } Tcl_StaticPackage(interp, "Tcltest", Tcltest_Init, (Tcl_PackageInitProc *) NULL); if (Tclxtest_Init (interp) == TCL_ERROR) { return TCL_ERROR; } Tcl_StaticPackage(interp, "Tclxtest", Tclxtest_Init, (Tcl_PackageInitProc *) NULL); return TCL_OK; } tclx8.4-8.4.1.orig/unix/tclXAppInit.c0000644000000000000000000000605512046313167014114 0ustar /* * tclXAppInit.c -- * * Provides a default version of the Tcl_AppInit procedure for use with * applications built with Extended Tcl on Unix systems. *----------------------------------------------------------------------------- * Copyright 1991-1999 Karl Lehenbauer and Mark Diekhans. * * Permission to use, copy, modify, and distribute this software and its * documentation for any purpose and without fee is hereby granted, provided * that the above copyright notice appear in all copies. Karl Lehenbauer and * Mark Diekhans make no representations about the suitability of this * software for any purpose. It is provided "as is" without express or * implied warranty. *----------------------------------------------------------------------------- * $Id: tclXAppInit.c,v 8.1 2001/10/24 23:31:50 hobbs Exp $ *----------------------------------------------------------------------------- */ #include "tclExtend.h" /* * The following variable is a special hack that insures the tcl * version of matherr() is used when linking against shared libraries. * Even if matherr is not used on this system, there is a dummy version * in libtcl. */ extern int matherr (); int (*tclDummyMathPtr)() = matherr; /*----------------------------------------------------------------------------- * main -- * * This is the main program for the application. *----------------------------------------------------------------------------- */ #ifdef __cplusplus int main (int argc, char **argv) #else int main (argc, argv) int argc; char **argv; #endif { TclX_Main(argc, argv, Tcl_AppInit); return 0; /* Needed only to prevent compiler warning. */ } /*----------------------------------------------------------------------------- * Tcl_AppInit -- * * This procedure performs application-specific initialization. Most * applications, especially those that incorporate additional packages, will * have their own version of this procedure. * * Results: * Returns a standard Tcl completion code, and leaves an error message in * interp result if an error occurs. *----------------------------------------------------------------------------- */ #ifdef __cplusplus int Tcl_AppInit (Tcl_Interp *interp) #else int Tcl_AppInit (interp) Tcl_Interp *interp; #endif { if (Tcl_Init (interp) == TCL_ERROR) { return TCL_ERROR; } if (Tclx_Init (interp) == TCL_ERROR) { return TCL_ERROR; } Tcl_StaticPackage (interp, "Tclx", Tclx_Init, Tclx_SafeInit); /* * Call Tcl_CreateCommand for application-specific commands, if * they weren't already created by the init procedures called above. */ /* * Specify a user-specific startup file to invoke if the application * is run interactively. Typically the startup file is "~/.apprc" * where "app" is the name of the application. If this line is deleted * then no user-specific startup file will be run under any conditions. */ Tcl_SetVar(interp, "tcl_rcFileName", "~/.tclrc", TCL_GLOBAL_ONLY); return TCL_OK; } tclx8.4-8.4.1.orig/unix/tclXunixSock.c0000644000000000000000000002641012046313167014350 0ustar /* * tclXunixSock.c -- * * Deprecated server creation commands, which are not supported on platforms * other than Unix. These commands are deprecated in favor of the Tcl socket * functionality, however they can't be implemented as backwards * compatibility procs. *--------------------------------------------------------------------------- * Copyright 1991-1999 Karl Lehenbauer and Mark Diekhans. * * Permission to use, copy, modify, and distribute this software and its * documentation for any purpose and without fee is hereby granted, provided * that the above copyright notice appear in all copies. Karl Lehenbauer and * Mark Diekhans make no representations about the suitability of this * software for any purpose. It is provided "as is" without express or * implied warranty. *----------------------------------------------------------------------------- * $Id: tclXunixSock.c,v 8.3 2004/11/23 00:13:14 hobbs Exp $ *----------------------------------------------------------------------------- */ #include "tclExtdInt.h" #define SERVER_BUF 1 #define SERVER_NOBUF 2 /* * Prototypes of internal functions. */ static void CloseForError _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Channel channel, int fileNum)); static int BindFileHandles _ANSI_ARGS_((Tcl_Interp *interp, unsigned options, int socketFD)); /*----------------------------------------------------------------------------- * CloseForError -- * * Close a file on error. If the file is associated with a channel, close * it too. The error number will be saved and not lost. * * Parameters: * o interp (I) - Current interpreter. * o channel (I) - Channel to close if not NULL. * o fileNum (I) - File number to close if >= 0. *----------------------------------------------------------------------------- */ static void CloseForError (interp, channel, fileNum) Tcl_Interp *interp; Tcl_Channel channel; int fileNum; { int saveErrNo = Tcl_GetErrno (); /* * Always close fileNum, even if channel close is done, as it doesn't * close stdin, stdout or stderr numbers. */ if (channel != NULL) Tcl_UnregisterChannel (interp, channel); if (fileNum >= 0) close (fileNum); Tcl_SetErrno (saveErrNo); } /*----------------------------------------------------------------------------- * BindFileHandles -- * * Bind the file handles for a socket to one or two Tcl file channels. * Binding to two handles is for compatibility with older interfaces. * If an error occurs, both file descriptors will be closed and cleaned up. * * Parameters: * o interp (O) - File handles or error messages are return in result. * o options (I) - Options set controling buffering and handle allocation: * o SERVER_BUF - Two file handle buffering. * o SERVER_NOBUF - No buffering. * o socketFD (I) - File number of the socket that was opened. * Returns: * TCL_OK or TCL_ERROR. *----------------------------------------------------------------------------- */ static int BindFileHandles (interp, options, socketFD) Tcl_Interp *interp; unsigned options; int socketFD; { Tcl_Channel channel; channel = Tcl_MakeTcpClientChannel ((ClientData) socketFD); Tcl_RegisterChannel (interp, channel); if (options & SERVER_NOBUF) { if (TclX_SetChannelOption (interp, channel, TCLX_COPT_BUFFERING, TCLX_BUFFERING_NONE) == TCL_ERROR) goto errorExit; } Tcl_AppendElement (interp, Tcl_GetChannelName (channel)); return TCL_OK; errorExit: CloseForError (interp, channel, socketFD); return TCL_ERROR; } /*----------------------------------------------------------------------------- * TclX_ServerCreateCmd -- * Implements the TCL server_create command: * * server_create ?options? * * Creates a socket, binds the address and port on the local machine * (optionally specified by the caller), and starts the port listening * for connections by calling listen (2). * * Options may be "-myip ip_address", "-myport port_number", * "-myport reserved", and "-backlog backlog". * * Results: * If successful, a Tcl fileid is returned. * *----------------------------------------------------------------------------- */ static int TclX_ServerCreateCmd (clientData, interp, argc, argv) ClientData clientData; Tcl_Interp *interp; int argc; char **argv; { int socketFD = -1, nextArg; struct sockaddr_in local; int myPort, value; int backlog = 5; int getReserved = FALSE; Tcl_Channel channel = NULL; /* * Parse arguments. */ bzero ((VOID *) &local, sizeof (local)); local.sin_family = AF_INET; local.sin_addr.s_addr = INADDR_ANY; nextArg = 1; while ((nextArg < argc) && (argv [nextArg][0] == '-')) { if (STREQU ("-myip", argv [nextArg])) { if (nextArg >= argc - 1) goto missingArg; nextArg++; if (TclXOSInetAtoN (interp, argv [nextArg], &local.sin_addr) == TCL_ERROR) return TCL_ERROR; } else if (STREQU ("-myport", argv [nextArg])) { if (nextArg >= argc - 1) goto missingArg; nextArg++; if (STREQU (argv [nextArg], "reserved")) { getReserved = TRUE; } else { if (Tcl_GetInt (interp, argv [nextArg], &myPort) != TCL_OK) return TCL_ERROR; local.sin_port = htons (myPort); } } else if (STREQU ("-backlog", argv [nextArg])) { if (nextArg >= argc - 1) goto missingArg; nextArg++; if (Tcl_GetInt (interp, argv [nextArg], &backlog) != TCL_OK) return TCL_ERROR; } else if (STREQU ("-reuseaddr", argv [nextArg])) { /* Ignore for compatibility */ } else { TclX_AppendObjResult (interp, "expected ", "\"-myip\", \"-myport\", or \"-backlog\", ", "got \"", argv [nextArg], "\"", (char *) NULL); return TCL_ERROR; } nextArg++; } if (nextArg != argc) { TclX_AppendObjResult (interp, tclXWrongArgs, argv[0], " ?options?", (char *) NULL); return TCL_ERROR; } /* * Allocate a reserved port if requested. */ if (getReserved) { int port; if (rresvport (&port) < 0) goto unixError; local.sin_port = port; } /* * Open a socket and bind an address and port to it. */ socketFD = socket (local.sin_family, SOCK_STREAM, 0); if (socketFD < 0) goto unixError; value = 1; if (setsockopt (socketFD, SOL_SOCKET, SO_REUSEADDR, (void*) &value, sizeof (value)) < 0) { goto unixError; } if (bind (socketFD, (struct sockaddr *) &local, sizeof (local)) < 0) { goto unixError; } if (listen (socketFD, backlog) < 0) goto unixError; channel = Tcl_MakeTcpClientChannel ((ClientData) socketFD); Tcl_RegisterChannel (interp, channel); TclX_AppendObjResult (interp, Tcl_GetChannelName (channel), (char *) NULL); return TCL_OK; /* * Exit points for errors. */ missingArg: TclX_AppendObjResult (interp, "missing argument for ", argv [nextArg], (char *) NULL); return TCL_ERROR; unixError: TclX_AppendObjResult (interp, Tcl_PosixError (interp), (char *) NULL); CloseForError (interp, channel, socketFD); return TCL_ERROR; } /*----------------------------------------------------------------------------- * TclX_ServerAcceptCmd -- * Implements the TCL server_accept command: * * server_accept ?options? file * * Accepts an IP connection request to a socket created by server_create. * Options maybe -buf orr -nobuf. * * Results: * If successful, a Tcl fileid. *----------------------------------------------------------------------------- */ static int TclX_ServerAcceptCmd (clientData, interp, argc, argv) ClientData clientData; Tcl_Interp *interp; int argc; char **argv; { Tcl_Channel channel; unsigned options; int acceptSocketFD, addrLen; int socketFD = -1; int nextArg; struct sockaddr_in connectSocket; /* * Parse arguments. */ nextArg = 1; options = SERVER_BUF; while ((nextArg < argc) && (argv [nextArg][0] == '-')) { if (STREQU ("-buf", argv [nextArg])) { options &= ~SERVER_NOBUF; options |= SERVER_BUF; } else if (STREQU ("-nobuf", argv [nextArg])) { options &= ~SERVER_BUF; options |= SERVER_NOBUF; } else { TclX_AppendObjResult (interp, "expected \"-buf\" or \"-nobuf\", ", "got \"", argv [nextArg], "\"", (char *) NULL); return TCL_ERROR; } nextArg++; } if (nextArg != argc - 1) { TclX_AppendObjResult (interp, tclXWrongArgs, argv[0], " ?options? fileid", (char *) NULL); return TCL_ERROR; } /* * Accept a socket connection on the socket created by server_create. */ bzero ((VOID *) &connectSocket, sizeof (connectSocket)); channel = TclX_GetOpenChannel (interp, argv [nextArg], 0); if (channel == NULL) return TCL_ERROR; if (Tcl_GetChannelHandle (channel, TCL_READABLE, (ClientData *)&acceptSocketFD) == TCL_ERROR) { if (Tcl_GetChannelHandle (channel, TCL_WRITABLE, (ClientData *)&acceptSocketFD) == TCL_ERROR) return TCL_ERROR; } if (acceptSocketFD < 0) return TCL_ERROR; addrLen = sizeof (connectSocket); socketFD = accept (acceptSocketFD, (struct sockaddr *)&connectSocket, &addrLen); if (socketFD < 0) goto unixError; /* * Set up channels and we are done. */ return BindFileHandles (interp, options, socketFD); /* * Exit points for errors. */ unixError: TclX_AppendObjResult (interp, Tcl_PosixError (interp), (char *) NULL); if (socketFD >= 0) close (socketFD); return TCL_ERROR; } /*----------------------------------------------------------------------------- * TclX_ServerInit -- * * Initialize the server commands in the specified interpreter. *----------------------------------------------------------------------------- */ void TclX_ServerInit (interp) Tcl_Interp *interp; { /* * These commands are deprecated in favor of the Tcl socket -server * functionality, however they can't be implemented as backwards * compatibility procs. */ Tcl_CreateCommand (interp, "server_accept", TclX_ServerAcceptCmd, (ClientData) NULL, (void (*)()) NULL); Tcl_CreateCommand (interp, "server_create", TclX_ServerCreateCmd, (ClientData) NULL, (void (*)()) NULL); } tclx8.4-8.4.1.orig/generic/0000755000000000000000000000000012046525461012176 5ustar tclx8.4-8.4.1.orig/generic/tclXfcntl.c0000644000000000000000000002536312046313170014304 0ustar /* * tclXfcntl.c * * Extended Tcl fcntl command. *----------------------------------------------------------------------------- * Copyright 1991-1999 Karl Lehenbauer and Mark Diekhans. * * Permission to use, copy, modify, and distribute this software and its * documentation for any purpose and without fee is hereby granted, provided * that the above copyright notice appear in all copies. Karl Lehenbauer and * Mark Diekhans make no representations about the suitability of this * software for any purpose. It is provided "as is" without express or * implied warranty. *----------------------------------------------------------------------------- * $Id: tclXfcntl.c,v 1.2 2005/01/19 03:20:47 hobbs Exp $ *----------------------------------------------------------------------------- */ #include "tclExtdInt.h" /* * Attributes sets used by fcntl command. */ #define ATTR_ERROR -1 /* Error parsing attributes. */ #define ATTR_RDONLY 1 /* Access checks desired. */ #define ATTR_WRONLY 2 #define ATTR_RDWR 3 #define ATTR_READ 4 #define ATTR_WRITE 5 #define ATTR_APPEND 6 #define ATTR_CLOEXEC 7 #define ATTR_NOBUF 8 #define ATTR_LINEBUF 9 #define ATTR_NONBLOCK 10 #define ATTR_KEEPALIVE 11 /* * The maximum length of any attribute name. */ #define MAX_ATTR_NAME_LEN 20 /* * Table of attribute names and values. */ static struct { char *name; int id; int modifiable; } TclXfcntlAttrNames [] = { {"RDONLY", ATTR_RDONLY, FALSE}, {"WRONLY", ATTR_WRONLY, FALSE}, {"RDWR", ATTR_RDWR, FALSE}, {"READ", ATTR_READ, FALSE}, {"WRITE", ATTR_WRITE, FALSE}, {"APPEND", ATTR_APPEND, TRUE}, {"CLOEXEC", ATTR_CLOEXEC, TRUE}, {"NONBLOCK", ATTR_NONBLOCK, TRUE}, {"LINEBUF", ATTR_LINEBUF, TRUE}, {"NOBUF", ATTR_NOBUF, TRUE}, {"KEEPALIVE", ATTR_KEEPALIVE, TRUE}, {NULL, 0, FALSE}}; /* * Prototypes of internal functions. */ static int XlateFcntlAttr _ANSI_ARGS_((Tcl_Interp *interp, char *attrName, int modify)); static int GetFcntlAttr _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Channel channel, int mode, int attrib)); static int SetFcntlAttrObj _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Channel channel, int attrib, Tcl_Obj *valueObj)); static int TclX_FcntlObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); /*----------------------------------------------------------------------------- * XlateFcntlAttr -- * Translate an fcntl attribute to an numberic id. * * Parameters: * o interp - Tcl interp, errors in result * o attrName - The attrbute name to translate, maybe upper or lower case. * o modify - Will the attribute be modified * Result: * The number associated with the attirbute, or ATTR_ERROR is an error * occures. *----------------------------------------------------------------------------- */ static int XlateFcntlAttr (interp, attrName, modify) Tcl_Interp *interp; char *attrName; int modify; { char attrNameUp [MAX_ATTR_NAME_LEN]; int idx; if (strlen (attrName) >= MAX_ATTR_NAME_LEN) goto invalidAttrName; TclX_UpShift (attrNameUp, attrName); for (idx = 0; TclXfcntlAttrNames [idx].name != NULL; idx++) { if (STREQU (attrNameUp, TclXfcntlAttrNames [idx].name)) { if (modify && !TclXfcntlAttrNames [idx].modifiable) { TclX_AppendObjResult (interp, "Attribute \"", attrName, "\" may not be altered after open", (char *) NULL); return ATTR_ERROR; } return TclXfcntlAttrNames [idx].id; } } /* * Invalid attribute. */ invalidAttrName: TclX_AppendObjResult (interp, "unknown attribute name \"", attrName, "\", expected one of ", (char *) NULL); for (idx = 0; TclXfcntlAttrNames [idx + 1].name != NULL; idx++) { TclX_AppendObjResult (interp, TclXfcntlAttrNames [idx].name, ", ", (char *) NULL); } TclX_AppendObjResult (interp, "or ", TclXfcntlAttrNames [idx].name, (char *) NULL); return ATTR_ERROR; } /*----------------------------------------------------------------------------- * GetFcntlAttr -- * Return the value of a specified fcntl attribute. * * Parameters: * o interp - Tcl interpreter, value is returned in the result * o channel - The channel to check. * o mode - Channel access mode. * o attrib - Attribute to get. * Result: * TCL_OK or TCL_ERROR *----------------------------------------------------------------------------- */ static int GetFcntlAttr (interp, channel, mode, attrib) Tcl_Interp *interp; Tcl_Channel channel; int mode; int attrib; { int value, optValue; switch (attrib) { case ATTR_RDONLY: value = (mode & TCL_READABLE) && !(mode & TCL_WRITABLE); break; case ATTR_WRONLY: value = (mode & TCL_WRITABLE) && !(mode & TCL_READABLE); break; case ATTR_RDWR: value = (mode & TCL_READABLE) && (mode & TCL_WRITABLE); break; case ATTR_READ: value = (mode & TCL_READABLE); break; case ATTR_WRITE: value = (mode & TCL_WRITABLE); break; case ATTR_APPEND: if (TclXOSGetAppend (interp, channel, &value) != TCL_OK) return TCL_ERROR; break; case ATTR_CLOEXEC: if (TclXOSGetCloseOnExec (interp, channel, &value) != TCL_OK) return TCL_ERROR; break; case ATTR_NONBLOCK: if (TclX_GetChannelOption (interp, channel, TCLX_COPT_BLOCKING, &optValue) != TCL_OK) return TCL_ERROR; value = (optValue == TCLX_MODE_NONBLOCKING); break; case ATTR_NOBUF: if (TclX_GetChannelOption (interp, channel, TCLX_COPT_BUFFERING, &optValue) != TCL_OK) return TCL_ERROR; value = (optValue == TCLX_BUFFERING_NONE); break; case ATTR_LINEBUF: if (TclX_GetChannelOption (interp, channel, TCLX_COPT_BUFFERING, &optValue) != TCL_OK) return TCL_ERROR; value = (optValue == TCLX_BUFFERING_LINE); break; case ATTR_KEEPALIVE: if (TclXOSgetsockopt (interp, channel, SO_KEEPALIVE, &value) != TCL_OK) return TCL_ERROR; break; default: panic ("bug in fcntl get attrib"); } Tcl_SetIntObj (Tcl_GetObjResult (interp), value != 0); return TCL_OK; } /*----------------------------------------------------------------------------- * SetFcntlAttrObj -- * Set the the attributes on a channel. * * Parameters: * o interp - Tcl interpreter, value is returned in the result * o channel - The channel to check. * o attrib - Atrribute to set. * o valueStr - Object value (all are boolean now). * Result: * TCL_OK or TCL_ERROR. *----------------------------------------------------------------------------- */ static int SetFcntlAttrObj (interp, channel, attrib, valueObj) Tcl_Interp *interp; Tcl_Channel channel; int attrib; Tcl_Obj *valueObj; { int value; if (Tcl_GetBooleanFromObj (interp, valueObj, &value) != TCL_OK) return TCL_ERROR; switch (attrib) { case ATTR_APPEND: if (TclXOSSetAppend (interp, channel, value) != TCL_OK) return TCL_ERROR; return TCL_OK; case ATTR_CLOEXEC: if (TclXOSSetCloseOnExec (interp, channel, value) != TCL_OK) return TCL_ERROR; return TCL_OK; case ATTR_NONBLOCK: return TclX_SetChannelOption (interp, channel, TCLX_COPT_BLOCKING, value ? TCLX_MODE_NONBLOCKING : TCLX_MODE_BLOCKING); case ATTR_NOBUF: return TclX_SetChannelOption (interp, channel, TCLX_COPT_BUFFERING, value ? TCLX_BUFFERING_NONE : TCLX_BUFFERING_FULL); case ATTR_LINEBUF: return TclX_SetChannelOption (interp, channel, TCLX_COPT_BUFFERING, value ? TCLX_BUFFERING_LINE : TCLX_BUFFERING_FULL); case ATTR_KEEPALIVE: return TclXOSsetsockopt (interp, channel, SO_KEEPALIVE, value); default: panic ("buf in fcntl set attrib"); } return TCL_ERROR; /* Should never be reached */ } /*----------------------------------------------------------------------------- * TclX_FcntlObjCmd -- * Implements the fcntl TCL command: * fcntl handle attribute ?value? *----------------------------------------------------------------------------- */ static int TclX_FcntlObjCmd (clientData, interp, objc, objv) ClientData clientData; Tcl_Interp *interp; int objc; Tcl_Obj *CONST objv[]; { Tcl_Channel channel; int mode; int attrib; char *channelString; char *fcntlAttributes; if ((objc < 3) || (objc > 4)) return TclX_WrongArgs (interp, objv [0], "handle attribute ?value?"); channelString = Tcl_GetStringFromObj (objv[1], NULL); channel = Tcl_GetChannel (interp, channelString, &mode); if (channel == NULL) { return TCL_ERROR; } fcntlAttributes = Tcl_GetStringFromObj (objv[2], NULL); attrib = XlateFcntlAttr (interp, fcntlAttributes, (objc == 4)); if (attrib == ATTR_ERROR) return TCL_ERROR; if (objc == 3) { if (GetFcntlAttr (interp, channel, mode, attrib) != TCL_OK) return TCL_ERROR; } else { if (SetFcntlAttrObj (interp, channel, attrib, objv[3]) != TCL_OK) return TCL_ERROR; } return TCL_OK; } /*----------------------------------------------------------------------------- * TclX_FcntlInit -- * Initialize the fcntl command. *----------------------------------------------------------------------------- */ void TclX_FcntlInit (interp) Tcl_Interp *interp; { Tcl_CreateObjCommand (interp, "fcntl", TclX_FcntlObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc*) NULL); } tclx8.4-8.4.1.orig/generic/tclXgeneral.c0000644000000000000000000004235512046313167014621 0ustar /* * tclXgeneral.c -- * * A collection of general commands: echo, infox and loop. *----------------------------------------------------------------------------- * Copyright 1991-1999 Karl Lehenbauer and Mark Diekhans. * * Permission to use, copy, modify, and distribute this software and its * documentation for any purpose and without fee is hereby granted, provided * that the above copyright notice appear in all copies. Karl Lehenbauer and * Mark Diekhans make no representations about the suitability of this * software for any purpose. It is provided "as is" without express or * implied warranty. *----------------------------------------------------------------------------- * $Id: tclXgeneral.c,v 1.4 2008/12/15 20:00:27 andreas_kupries Exp $ *----------------------------------------------------------------------------- */ #include "tclExtdInt.h" /* * Values returned by the infox command. */ static char *tclxVersion = FULL_VERSION; static int tclxPatchlevel = TCLX_PATCHLEVEL; static char *tclAppName = NULL; static char *tclAppLongName = NULL; static char *tclAppVersion = NULL; static int tclAppPatchlevel = -1; static int TclX_EchoObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int TclX_InfoxObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int TclX_LoopObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int SetLoopCounter _ANSI_ARGS_((Tcl_Interp *interp, char *varName, int idx)); static int GlobalImport _ANSI_ARGS_((Tcl_Interp *interp)); static int TclX_Try_EvalObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); /*----------------------------------------------------------------------------- * TclX_SetAppInfo -- * Store the application information returned by infox. * * Parameters: * o defaultValues (I) - If true, then the values are assigned only if they * are not already defined (defaulted). If false, the values are always * set. * o appName (I) - Application symbolic name. * o appLongName (I) - Long, natural language application name. * o appVersion (I) - Version number of the application. * o appPatchlevel (I) - Patch level of the application. If less than * zero, don't change. * Notes: * String pointers are saved without copying, don't release the memory. * If the arguments are NULL, don't change the values. *----------------------------------------------------------------------------- */ void TclX_SetAppInfo (defaultValues, appName, appLongName, appVersion, appPatchlevel) int defaultValues; char *appName; char *appLongName; char *appVersion; int appPatchlevel; { if ((appName != NULL) && ((!defaultValues) || (tclAppName == NULL))) { tclAppName = appName; } if ((appLongName != NULL) && ((!defaultValues) || (tclAppLongName == NULL))) { tclAppLongName = appLongName; } if ((appVersion != NULL) && ((!defaultValues) || (tclAppVersion == NULL))) { tclAppVersion = appVersion; } if ((appPatchlevel >= 0) && ((!defaultValues) || (tclAppPatchlevel < 0))) { tclAppPatchlevel = appPatchlevel; } } /*----------------------------------------------------------------------------- * TclX_EchoObjCmd -- * Implements the TclX echo command: * echo ?str ...? * * Results: * Always returns TCL_OK. *----------------------------------------------------------------------------- */ static int TclX_EchoObjCmd (dummy, interp, objc, objv) ClientData dummy; Tcl_Interp *interp; int objc; Tcl_Obj *CONST objv[]; { int idx; Tcl_Channel channel; #ifndef TCL_UTF_MAX char *stringPtr; int stringPtrLen; #endif channel = TclX_GetOpenChannel (interp, "stdout", TCL_WRITABLE); if (channel == NULL) return TCL_ERROR; for (idx = 1; idx < objc; idx++) { #ifndef TCL_UTF_MAX stringPtr = Tcl_GetStringFromObj (objv [idx], &stringPtrLen); if (Tcl_Write (channel, stringPtr, stringPtrLen) < 0) #else if (Tcl_WriteObj(channel, objv[idx]) < 0) #endif goto posixError; if (idx < (objc - 1)) { if (Tcl_Write (channel, " ", 1) < 0) goto posixError; } } if (TclX_WriteNL (channel) < 0) goto posixError; return TCL_OK; posixError: Tcl_SetStringObj (Tcl_GetObjResult (interp), Tcl_PosixError (interp), -1); return TCL_ERROR; } /*----------------------------------------------------------------------------- * TclX_InfoxObjCmd -- * Implements the TclX infox command: * infox option *----------------------------------------------------------------------------- */ static int TclX_InfoxObjCmd (clientData, interp, objc, objv) ClientData clientData; Tcl_Interp *interp; int objc; Tcl_Obj *CONST objv[]; { Tcl_Obj *resultPtr = Tcl_GetObjResult (interp); char *optionPtr; /* * FIX: Need a way to get the have_ functionality from the OS-dependent * code. */ if (objc != 2) { return TclX_WrongArgs (interp, objv[0], "option"); } optionPtr = Tcl_GetStringFromObj (objv[1], NULL); if (STREQU ("version", optionPtr)) { if (tclxVersion != NULL) { Tcl_SetStringObj (resultPtr, tclxVersion, -1); } return TCL_OK; } if (STREQU ("patchlevel", optionPtr)) { Tcl_SetIntObj (resultPtr, tclxPatchlevel); return TCL_OK; } if (STREQU ("have_fchown", optionPtr)) { # ifndef NO_FCHOWN Tcl_SetBooleanObj (resultPtr, TRUE); # else Tcl_SetBooleanObj (resultPtr, FALSE); # endif return TCL_OK; } if (STREQU ("have_fchmod", optionPtr)) { # ifndef NO_FCHMOD Tcl_SetBooleanObj (resultPtr, TRUE); # else Tcl_SetBooleanObj (resultPtr, FALSE); # endif return TCL_OK; } if (STREQU ("have_flock", optionPtr)) { if (TclXOSHaveFlock ()) Tcl_SetBooleanObj (resultPtr, TRUE); else Tcl_SetBooleanObj (resultPtr, FALSE); return TCL_OK; } if (STREQU ("have_fsync", optionPtr)) { # ifndef NO_FSYNC Tcl_SetBooleanObj (resultPtr, TRUE); # else Tcl_SetBooleanObj (resultPtr, FALSE); # endif return TCL_OK; } if (STREQU ("have_ftruncate", optionPtr)) { # if (!defined(NO_FTRUNCATE)) || defined(HAVE_CHSIZE) Tcl_SetBooleanObj (resultPtr, TRUE); # else Tcl_SetBooleanObj (resultPtr, FALSE); # endif return TCL_OK; } if (STREQU ("have_msgcats", optionPtr)) { # ifndef NO_CATGETS Tcl_SetBooleanObj (resultPtr, TRUE); # else Tcl_SetBooleanObj (resultPtr, FALSE); # endif return TCL_OK; } if (STREQU ("have_posix_signals", optionPtr)) { # ifndef NO_SIGACTION Tcl_SetBooleanObj (resultPtr, TRUE); # else Tcl_SetBooleanObj (resultPtr, FALSE); # endif return TCL_OK; } if (STREQU ("have_signal_restart", optionPtr)) { # ifndef NO_SIG_RESTART Tcl_SetBooleanObj (resultPtr, TRUE); # else Tcl_SetBooleanObj (resultPtr, FALSE); # endif return TCL_OK; } if (STREQU ("have_truncate", optionPtr)) { # ifndef NO_TRUNCATE Tcl_SetBooleanObj (resultPtr, TRUE); # else Tcl_SetBooleanObj (resultPtr, FALSE); # endif return TCL_OK; } if (STREQU ("have_symlink", optionPtr)) { # ifdef S_IFLNK Tcl_SetBooleanObj (resultPtr, TRUE); # else Tcl_SetBooleanObj (resultPtr, FALSE); # endif return TCL_OK; } if (STREQU ("have_waitpid", optionPtr)) { # ifndef NO_WAITPID Tcl_SetBooleanObj (resultPtr, TRUE); # else Tcl_SetBooleanObj (resultPtr, FALSE); # endif return TCL_OK; } if (STREQU ("appname", optionPtr)) { if (tclAppName != NULL) { Tcl_SetStringObj (resultPtr, tclAppName, -1); } return TCL_OK; } if (STREQU ("applongname", optionPtr)) { if (tclAppLongName != NULL) Tcl_SetStringObj (resultPtr, tclAppLongName, -1); return TCL_OK; } if (STREQU ("appversion", optionPtr)) { if (tclAppVersion != NULL) Tcl_SetStringObj (resultPtr, tclAppVersion, -1); return TCL_OK; } if (STREQU ("apppatchlevel", optionPtr)) { if (tclAppPatchlevel >= 0) Tcl_SetIntObj (resultPtr, tclAppPatchlevel); else Tcl_SetIntObj (resultPtr, 0); return TCL_OK; } TclX_AppendObjResult (interp, "illegal option \"", optionPtr, "\", expect one of: version, patchlevel, ", "have_fchown, have_fchmod, have_flock, ", "have_fsync, have_ftruncate, have_msgcats, ", "have_symlink, have_truncate, ", "have_posix_signals, have_waitpid, appname, ", "applongname, appversion, or apppatchlevel", (char *) NULL); return TCL_ERROR; } /*----------------------------------------------------------------------------- * SetLoopCounter -- * Set the loop command counter variable. *----------------------------------------------------------------------------- */ static int SetLoopCounter (interp, varName, idx) Tcl_Interp *interp; char *varName; int idx; { Tcl_Obj *iObj, *newVarObj; iObj = Tcl_GetVar2Ex(interp, varName, NULL, TCL_PARSE_PART1); if ((iObj == NULL) || (Tcl_IsShared (iObj))) { iObj = newVarObj = Tcl_NewLongObj (idx); } else { newVarObj = NULL; } Tcl_SetLongObj (iObj, idx); if (Tcl_SetVar2Ex(interp, varName, NULL, iObj, TCL_PARSE_PART1|TCL_LEAVE_ERR_MSG) == NULL) { if (newVarObj != NULL) { Tcl_DecrRefCount (newVarObj); } return TCL_ERROR; } return TCL_OK; } /*----------------------------------------------------------------------------- * TclX_LoopObjCmd -- * Implements the TclX loop command: * loop var start end ?increment? command * * Results: * Standard TCL results. *----------------------------------------------------------------------------- */ static int TclX_LoopObjCmd (dummy, interp, objc, objv) ClientData dummy; Tcl_Interp *interp; int objc; Tcl_Obj *CONST objv[]; { int result = TCL_OK; long idx, first, limit, incr = 1; char *varName; Tcl_Obj *command; if ((objc < 5) || (objc > 6)) { return TclX_WrongArgs (interp, objv [0], "var first limit ?incr? command"); } if (Tcl_ExprLongObj (interp, objv [2], &first) != TCL_OK) return TCL_ERROR; if (Tcl_ExprLongObj (interp, objv [3], &limit) != TCL_OK) return TCL_ERROR; if (objc == 5) { command = objv [4]; } else { if (Tcl_ExprLongObj (interp, objv [4], &incr) != TCL_OK) return TCL_ERROR; command = objv [5]; } varName = Tcl_GetStringFromObj (objv[1], NULL); for (idx = first; (((idx < limit) && (incr >= 0)) || ((idx > limit) && (incr < 0))); idx += incr) { if (SetLoopCounter(interp, varName, idx) == TCL_ERROR) return TCL_ERROR; result = Tcl_EvalObj (interp, command); if (result == TCL_CONTINUE) { result = TCL_OK; } else if (result != TCL_OK) { if (result == TCL_BREAK) { result = TCL_OK; } else if (result == TCL_ERROR) { char buf [64]; sprintf (buf, "\n (\"loop\" body line %d)", ERRORLINE(interp)); Tcl_AddErrorInfo (interp, buf); } break; } } /* * Set loop counter to its final value. */ if (SetLoopCounter(interp, varName, idx) == TCL_ERROR) return TCL_ERROR; return result; } /*----------------------------------------------------------------------------- * GlobalImport -- * Import the errorResult, errorInfo, and errorCode global variable into the * current environment by calling the global command directly. * * Parameters: * o interp (I) - Current interpreter, Result is preserved. * Returns: * TCL_OK or TCL_ERROR. *----------------------------------------------------------------------------- */ static int GlobalImport (interp) Tcl_Interp *interp; { static char global [] = "global"; Tcl_Obj *savedResult; Tcl_CmdInfo cmdInfo; #define globalObjc (4) Tcl_Obj *globalObjv [globalObjc]; int idx, code = TCL_OK; savedResult = Tcl_DuplicateObj (Tcl_GetObjResult (interp)); if (!Tcl_GetCommandInfo (interp, global, &cmdInfo)) { TclX_AppendObjResult (interp, "can't find \"global\" command", (char *) NULL); goto errorExit; } globalObjv [0] = Tcl_NewStringObj (global, -1); globalObjv [1] = Tcl_NewStringObj ("errorResult", -1); globalObjv [2] = Tcl_NewStringObj ("errorInfo", -1); globalObjv [3] = Tcl_NewStringObj ("errorCode", -1); for (idx = 0; idx < globalObjc; idx++) { Tcl_IncrRefCount (globalObjv [idx]); } code = (*cmdInfo.objProc) (cmdInfo.objClientData, interp, globalObjc, globalObjv); for (idx = 0; idx < globalObjc; idx++) { Tcl_DecrRefCount (globalObjv [idx]); } if (code == TCL_ERROR) goto errorExit; Tcl_SetObjResult (interp, savedResult); return TCL_OK; errorExit: Tcl_DecrRefCount (savedResult); return TCL_ERROR; } /*----------------------------------------------------------------------------- * TclX_Try_EvalObjCmd -- * Implements the TclX try_eval command: * try_eval code catch ?finally? * * Results: * Standard TCL results. *----------------------------------------------------------------------------- */ static int TclX_Try_EvalObjCmd (dummy, interp, objc, objv) ClientData dummy; Tcl_Interp *interp; int objc; Tcl_Obj *CONST objv[]; { int code, code2; int haveFinally; Tcl_Obj *savedResultsPtr, *resultObjPtr; if ((objc < 3) || (objc > 4)) { return TclX_WrongArgs (interp, objv [0], "code catch ?finally?"); } haveFinally = (objc >= 4) && !TclX_IsNullObj (objv [3]); /* * Evaluate the command. If not error and no finally command, we are done. */ code = Tcl_EvalObj (interp, objv [1]); if ((code != TCL_ERROR) && !haveFinally) { return code; } /* * Process error block, if available. It's results becomes the command's * result. */ if ((!TclX_IsNullObj (objv [2])) && (code == TCL_ERROR)) { resultObjPtr = Tcl_DuplicateObj (Tcl_GetObjResult (interp)); Tcl_IncrRefCount (resultObjPtr); Tcl_ResetResult (interp); code = GlobalImport (interp); if (code != TCL_ERROR) { if (Tcl_SetVar2Ex(interp, "errorResult", NULL, resultObjPtr, TCL_LEAVE_ERR_MSG) == NULL) { code = TCL_ERROR; } } if (code != TCL_ERROR) { code = Tcl_EvalObj (interp, objv [2]); } Tcl_DecrRefCount (resultObjPtr); } /* * If a finally command is supplied, evaluate it, preserving the error * status. */ if (haveFinally) { savedResultsPtr = TclX_SaveResultErrorInfo (interp); Tcl_ResetResult (interp); code2 = Tcl_EvalObj (interp, objv [3]); if (code2 == TCL_ERROR) { Tcl_DecrRefCount (savedResultsPtr); /* Don't restore results */ code = code2; } else { TclX_RestoreResultErrorInfo (interp, savedResultsPtr); } } return code; } /*----------------------------------------------------------------------------- * TclX_GeneralInit -- * Initialize the command. *----------------------------------------------------------------------------- */ void TclX_GeneralInit (interp) Tcl_Interp *interp; { Tcl_CreateObjCommand (interp, "echo", TclX_EchoObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc*) NULL); Tcl_CreateObjCommand(interp, "infox", TclX_InfoxObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc*) NULL); Tcl_CreateObjCommand(interp, "loop", TclX_LoopObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc*) NULL); Tcl_CreateObjCommand(interp, "try_eval", TclX_Try_EvalObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc*) NULL); } tclx8.4-8.4.1.orig/generic/tclXdup.c0000644000000000000000000002151612046313170013762 0ustar /* * tclXdup.c * * Extended Tcl dup command. *----------------------------------------------------------------------------- * Copyright 1991-1999 Karl Lehenbauer and Mark Diekhans. * * Permission to use, copy, modify, and distribute this software and its * documentation for any purpose and without fee is hereby granted, provided * that the above copyright notice appear in all copies. Karl Lehenbauer and * Mark Diekhans make no representations about the suitability of this * software for any purpose. It is provided "as is" without express or * implied warranty. *----------------------------------------------------------------------------- * $Id: tclXdup.c,v 1.3 2005/04/26 20:01:33 hobbs Exp $ *----------------------------------------------------------------------------- */ #include "tclExtdInt.h" /* * Prototypes of internal functions. */ static int DupChannelOptions _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Channel srcChannel, Tcl_Channel targetChannel)); static Tcl_Channel DupFileChannel _ANSI_ARGS_((Tcl_Interp *interp, char *srcFileId, char *targetFileId)); static int TclX_DupObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); /*----------------------------------------------------------------------------- * DupChannelOptions -- * * Set the channel options of one channel to those of another. * * Parameters: * o interp (I) - Errors returned in result. * o srcChannel (I) - Channel to get the options. * o targetChannel (I) - Channel to set the options on. * Result: * TCL_OK or TCL_ERROR; *----------------------------------------------------------------------------- */ static int DupChannelOptions (interp, srcChannel, targetChannel) Tcl_Interp *interp; Tcl_Channel srcChannel; Tcl_Channel targetChannel; { Tcl_DString strValues; CONST84 char *option, *value, **optArgv = NULL; int optArgc, idx; Tcl_DStringInit (&strValues); if (Tcl_GetChannelOption (interp, srcChannel, NULL, &strValues) != TCL_OK) { goto errorExit; } /* * Split the list for each name/value pair and set the new channel. * Only modify blocking if its not the default, as setting blocking on * standard files generates an error on some systems. Skip options * that can't be set. */ if (Tcl_SplitList(interp, strValues.string, &optArgc, &optArgv) != TCL_OK) { goto errorExit; } if ((optArgc % 2) != 0) { panic("channel didn't return keyword/value pairs"); } for (idx = 0; idx < optArgc; idx += 2) { option = optArgv[idx]; value = optArgv[idx+1]; if (STREQU (option, "-blocking") && (value [0] != '0')) { continue; } if (STREQU (option, "-peername") || STREQU (option, "-sockname")) { continue; } if (Tcl_SetChannelOption (interp, targetChannel, option, value) != TCL_OK) { goto errorExit; } } Tcl_DStringFree (&strValues); if (optArgv != NULL) { ckfree((char *)optArgv); } return TCL_OK; errorExit: Tcl_DStringFree (&strValues); if (optArgv != NULL) { ckfree((char *)optArgv); } return TCL_ERROR; } /*----------------------------------------------------------------------------- * DupFileChannel -- * Do common work for all platforms for duplicate a channel * * Parameters: * o interp (I) - If an error occures, the error message is in result. * o srcChannelId (I) - The id of the channel to dup. * o targetChannelId (I) - The id for the new file. NULL if any id maybe * used. * Returns: * The unregistered channel, or NULL if an error occurs. *----------------------------------------------------------------------------- */ static Tcl_Channel DupFileChannel (interp, srcChannelId, targetChannelId) Tcl_Interp *interp; char *srcChannelId; char *targetChannelId; { Tcl_Channel srcChannel, newChannel = NULL; Tcl_ChannelType *channelType; int mode; srcChannel = Tcl_GetChannel (interp, srcChannelId, &mode); if (srcChannel == NULL) { return NULL; } channelType = Tcl_GetChannelType (srcChannel); if (STREQU (channelType->typeName, "pipe")) { TclX_AppendObjResult (interp, "can not \"dup\" a Tcl command ", "pipeline created with the \"open\" command", (char *) NULL); return NULL; } /* * If writable, flush out the buffer. */ if (mode & TCL_WRITABLE) { if (Tcl_Flush (srcChannel) == TCL_ERROR) goto posixError; } /* * Use OS dependent function to actually dup the channel. */ newChannel = TclXOSDupChannel (interp, srcChannel, mode, targetChannelId); if (newChannel == NULL) return NULL; /* * If the channel is open for reading and seekable, seek the new channel * to the same position. Tcl_Tell returns -1 if seek is not supported. */ if (mode & TCL_READABLE) { int seekOffset = (int) Tcl_Tell (srcChannel); if (seekOffset >= 0) { if (Tcl_Seek (newChannel, seekOffset, SEEK_SET) < 0) goto posixError; } } if (DupChannelOptions (interp, srcChannel, newChannel) != TCL_OK) goto errorExit; return newChannel; posixError: Tcl_ResetResult (interp); TclX_AppendObjResult (interp, "dup of \"", srcChannelId, "\" failed: ", Tcl_PosixError (interp), (char *) NULL); errorExit: if (newChannel != NULL) { Tcl_Close (NULL, newChannel); } return NULL; } /*----------------------------------------------------------------------------- * TclX_DupObjCmd -- * Implements the dup TCL command: * dup channelId ?targetChannelId? *----------------------------------------------------------------------------- */ static int TclX_DupObjCmd (clientData, interp, objc, objv) ClientData clientData; Tcl_Interp *interp; int objc; Tcl_Obj *CONST objv[]; { Tcl_Channel newChannel; int bindFnum, fnum; char *srcChannelId, *targetChannelId; if ((objc < 2) || (objc > 3)) { return TclX_WrongArgs (interp, objv [0], "channelId ?targetChannelId?"); } /* * If a number is supplied, bind it to a file handle rather than doing * a dup. */ if (objv [1]->typePtr == Tcl_GetObjType ("int")) { bindFnum = TRUE; } else { srcChannelId = Tcl_GetStringFromObj (objv [1], NULL); if (ISDIGIT (srcChannelId [0])) { if (Tcl_ConvertToType (interp, objv [1], Tcl_GetObjType ("int")) != TCL_OK) goto badFnum; bindFnum = TRUE; } else { bindFnum = FALSE; } } if (bindFnum) { if (objc != 2) goto bind2ndArg; if (Tcl_GetIntFromObj (interp, objv [1], &fnum) != TCL_OK) return TCL_ERROR; newChannel = TclXOSBindOpenFile (interp, fnum); } else { if (objc > 2) { targetChannelId = Tcl_GetStringFromObj (objv [2], NULL); } else { targetChannelId = NULL; } newChannel = DupFileChannel (interp, srcChannelId, targetChannelId); } if (newChannel == NULL) return TCL_ERROR; Tcl_RegisterChannel (interp, newChannel); Tcl_SetStringObj (Tcl_GetObjResult (interp), Tcl_GetChannelName (newChannel), -1); return TCL_OK; badFnum: Tcl_ResetResult (interp); TclX_AppendObjResult (interp, "invalid integer file number \"", Tcl_GetStringFromObj (objv [1], NULL), "\", expected unsigned integer or Tcl file id", (char *) NULL); return TCL_ERROR; bind2ndArg: TclX_AppendObjResult (interp, "the second argument, targetChannelId, ", "is not allow when binding a file number to ", "a Tcl channel", (char *) NULL); return TCL_ERROR; } /*----------------------------------------------------------------------------- * TclX_DupInit -- * Initialize the dip command in an interpreter. * * Parameters: * o interp - Interpreter to add commandsto. *----------------------------------------------------------------------------- */ void TclX_DupInit (interp) Tcl_Interp *interp; { Tcl_CreateObjCommand (interp, "dup", TclX_DupObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc*) NULL); } tclx8.4-8.4.1.orig/generic/tclXlgets.c0000644000000000000000000003744712046313167014330 0ustar /* * tclXlgets.c * * Extended Tcl lgets command. *----------------------------------------------------------------------------- * Copyright 1991-1999 Karl Lehenbauer and Mark Diekhans. * * Permission to use, copy, modify, and distribute this software and its * documentation for any purpose and without fee is hereby granted, provided * that the above copyright notice appear in all copies. Karl Lehenbauer and * Mark Diekhans make no representations about the suitability of this * software for any purpose. It is provided "as is" without express or * implied warranty. *----------------------------------------------------------------------------- * $Id: tclXlgets.c,v 1.1 2001/10/24 23:31:48 hobbs Exp $ *----------------------------------------------------------------------------- */ /* *----------------------------------------------------------------------------- * Note: The list parsing code is from Tcl distribution file tclUtil.c, * procedure TclFindElement: * Copyright (c) 1987-1993 The Regents of the University of California. * Copyright (c) 1994-1997 Sun Microsystems, Inc. *----------------------------------------------------------------------------- */ #include "tclExtdInt.h" /* * State for current list being read. */ typedef struct { Tcl_Channel channel; /* Channel to read from */ Tcl_DString buffer; /* Buffer for line being read */ int lineIdx; /* Index of next line to read. */ } ReadData; /* * Prototypes of internal functions. */ static int ReadListLine _ANSI_ARGS_((Tcl_Interp *interp, ReadData *dataPtr)); static int ReadListInit _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Channel channel, ReadData *dataPtr)); static int ReadListElement _ANSI_ARGS_((Tcl_Interp *interp, ReadData *dataPtr, Tcl_Obj *elemObjPtr)); static int TclX_LgetsObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); /*----------------------------------------------------------------------------- * ReadLineList -- * * Read a list line from a channel. * * Paramaters: * o interp - Errors are returned in result. * o dataPtr - Data for list read. * Returns: * o TCL_OK if read succeeded.. * o TCL_BREAK if EOF without reading any data. * o TCL_ERROR if an error occured, with error message in interp. *----------------------------------------------------------------------------- */ static int ReadListLine (interp, dataPtr) Tcl_Interp *interp; ReadData *dataPtr; { /* * Read the first line of the list. */ if (Tcl_Gets (dataPtr->channel, &dataPtr->buffer) < 0) { if (Tcl_Eof (dataPtr->channel)) { /* * If not first read, then we have failed in the middle of a list. */ if (dataPtr->lineIdx > 0) { TclX_AppendObjResult (interp, "EOF in list element", (char *) NULL); return TCL_ERROR; } return TCL_BREAK; /* EOF with no data */ } TclX_AppendObjResult (interp, Tcl_PosixError (interp), (char *) NULL); return TCL_ERROR; } /* * If data was read, but the read terminate with an EOF rather than a * newline, its an error. */ if (Tcl_Eof (dataPtr->channel)) { TclX_AppendObjResult (interp, "EOF encountered before newline while reading ", "list from channel", (char *) NULL); return TCL_ERROR; } /* * Add back in the newline. */ Tcl_DStringAppend (&dataPtr->buffer, "\n", 1); return TCL_OK; } /*----------------------------------------------------------------------------- * ReadListInit -- * * Initialize for reading list elements from a file. * * Paramaters: * o interp - Errors are returned in result. * o channel - The channel to read from. * o dataPtr - Data for list read. * Returns: * o TCL_OK if read to read. * o TCL_BREAK if EOF without reading any data. * o TCL_ERROR if an error occured, with error message in interp. *----------------------------------------------------------------------------- */ static int ReadListInit (interp, channel, dataPtr) Tcl_Interp *interp; Tcl_Channel channel; ReadData *dataPtr; { int rstat; char *p, *limit; dataPtr->channel = channel; Tcl_DStringInit (&dataPtr->buffer); dataPtr->lineIdx = 0; rstat = ReadListLine (interp, dataPtr); if (rstat != TCL_OK) return rstat; /* * Advance to the first non-whitespace. */ p = Tcl_DStringValue (&dataPtr->buffer); limit = p + Tcl_DStringLength (&dataPtr->buffer); while ((p < limit) && (isspace(UCHAR(*p)))) { p++; } dataPtr->lineIdx = p - Tcl_DStringValue (&dataPtr->buffer); return TCL_OK; } /*----------------------------------------------------------------------------- * ReadListElement -- * * Read the next element of the list. If the end of the string is reached * while still in the list element, read another line. * * Paramaters: * o interp - Errors are returned in result. * o dataPtr - Data for list read. As initialized by ReadListInit. * o elemObjPtr - An object to copy the list element to. * Returns: * o TCL_OK if an element was read. * o TCL_BREAK if the end of the list was reached. * o TCL_ERROR if an error occured. * Notes: * Code is a modified version of UCB procedure tclUtil.c:TclFindElement *----------------------------------------------------------------------------- */ static int ReadListElement (interp, dataPtr, elemObjPtr) Tcl_Interp *interp; ReadData *dataPtr; Tcl_Obj *elemObjPtr; { register char *p; char *cpStart; /* Points to next byte to copy. */ char *limit; /* Points just after list's last byte. */ int openBraces = 0; /* Brace nesting level during parse. */ int inQuotes = 0; int numChars; char *p2; int rstat, cpIdx; p = Tcl_DStringValue (&dataPtr->buffer) + dataPtr->lineIdx; limit = Tcl_DStringValue (&dataPtr->buffer) + Tcl_DStringLength (&dataPtr->buffer); /* * If we are at the end of the string, there are no more elements. */ if (p == limit) { /* no element found */ return TCL_BREAK; } /* * Check for an opening brace or quote. We treat embedded NULLs in the * list as bytes belonging to a list element. */ if (*p == '{') { openBraces = 1; p++; } else if (*p == '"') { inQuotes = 1; p++; } cpStart = p; /* * Find element's end (a space, close brace, or the end of the string). */ while (1) { switch (*p) { /* * Open brace: don't treat specially unless the element is in * braces. In this case, keep a nesting count. */ case '{': if (openBraces != 0) { openBraces++; } break; /* * Close brace: if element is in braces, keep nesting count and * quit when the last close brace is seen. */ case '}': if (openBraces > 1) { openBraces--; } else if (openBraces == 1) { Tcl_AppendToObj (elemObjPtr, cpStart, (p - cpStart)); p++; if ((p >= limit) || isspace(UCHAR(*p))) { goto done; } /* * Garbage after the closing brace; return an error. */ if (interp != NULL) { char buf[100]; p2 = p; while ((p2 < limit) && (!isspace(UCHAR(*p2))) && (p2 < p+20)) { p2++; } sprintf(buf, "list element in braces followed by \"%.*s\" instead of space", (int) (p2-p), p); Tcl_ResetResult (interp); TclX_AppendObjResult (interp, buf, (char *) NULL); } return TCL_ERROR; } break; /* * Backslash: skip over everything up to the end of the * backslash sequence. Copy the character to the output obj * and reset the location of the rest of the string to copy. * If in braces, include backslash and character as-is, otherwise * drop it. */ case '\\': { char bsChar; bsChar = Tcl_Backslash(p, &numChars); if (openBraces > 0) { p += (numChars - 1); /* Advanced again at end of loop */ } else { Tcl_AppendToObj (elemObjPtr, cpStart, (p - cpStart)); Tcl_AppendToObj (elemObjPtr, &bsChar, 1); p += (numChars - 1); cpStart = p + 1; /* already stored character */ } break; } /* * Space: ignore if element is in braces or quotes; otherwise * terminate element. */ case ' ': case '\f': case '\n': case '\r': case '\t': case '\v': if ((openBraces == 0) && !inQuotes) { Tcl_AppendToObj (elemObjPtr, cpStart, (p - cpStart)); goto done; } break; /* * Double-quote: if element is in quotes then terminate it. */ case '"': if (inQuotes) { Tcl_AppendToObj (elemObjPtr, cpStart, (p - cpStart)); p++; if ((p >= limit) || isspace(UCHAR(*p))) { goto done; } /* * Garbage after the closing quote; return an error. */ if (interp != NULL) { char buf[100]; p2 = p; while ((p2 < limit) && (!isspace(UCHAR(*p2))) && (p2 < p+20)) { p2++; } sprintf(buf, "list element in quotes followed by \"%.*s\" %s", (int) (p2-p), p, "instead of space"); Tcl_ResetResult (interp); TclX_AppendObjResult (interp, buf, (char *) NULL); } return TCL_ERROR; } break; /* * Zero byte. */ case 0: { /* * If we are not at the end of the string, this is just * binary data in the list.. */ if (p != limit) break; /* Byte of zero */ if ((openBraces == 0) && (inQuotes == 0)) { Tcl_AppendToObj (elemObjPtr, cpStart, (p - cpStart)); goto done; } /* * Need new line. Buffer might be realloc-ed, so recalculate * pointers. Note we set `p' to one back, since we don't want * the p++ below to miss the next character. */ dataPtr->lineIdx = p - Tcl_DStringValue (&dataPtr->buffer); cpIdx = cpStart - Tcl_DStringValue (&dataPtr->buffer); rstat = ReadListLine (interp, dataPtr); if (rstat != TCL_OK) return rstat; p = Tcl_DStringValue (&dataPtr->buffer) + dataPtr->lineIdx - 1; limit = Tcl_DStringValue (&dataPtr->buffer) + Tcl_DStringLength (&dataPtr->buffer); cpStart = Tcl_DStringValue (&dataPtr->buffer) + cpIdx; } } p++; } done: while ((p < limit) && (isspace(UCHAR(*p)))) { p++; } dataPtr->lineIdx = p - Tcl_DStringValue (&dataPtr->buffer); return TCL_OK; } /*----------------------------------------------------------------------------- * Tcl_LgetsObjCmd -- * * Implements the `lgets' Tcl command: * lgets fileId ?varName? * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. *----------------------------------------------------------------------------- */ static int TclX_LgetsObjCmd (clientData, interp, objc, objv) ClientData clientData; Tcl_Interp *interp; int objc; Tcl_Obj *CONST objv[]; { Tcl_Channel channel; ReadData readData; int rstat, optValue; Tcl_Obj *elemObj, *dataObj; if ((objc < 2) || (objc > 3)) { return TclX_WrongArgs (interp, objv [0], "fileId ?varName?"); } channel = TclX_GetOpenChannelObj (interp, objv [1], TCL_READABLE); if (channel == NULL) return TCL_ERROR; /* * If the channel is non-blocking, its an error, we don't support it * yet. * FIX: Make callback driven for non-blocking. */ if (TclX_GetChannelOption (interp, channel, TCLX_COPT_BLOCKING, &optValue) != TCL_OK) return TCL_ERROR; if (optValue == TCLX_MODE_NONBLOCKING) { TclX_AppendObjResult (interp, "channel is non-blocking; not ", "currently supported by the lgets command", (char *) NULL); return TCL_ERROR; } /* * Read the list, parsing off each element until the list is read. * More lines are read if newlines are encountered in the middle of * a list. */ rstat = ReadListInit (interp, channel, &readData); dataObj = Tcl_NewListObj (0, NULL); Tcl_IncrRefCount (dataObj); while (rstat == TCL_OK) { elemObj = Tcl_NewStringObj ("", 0); rstat = ReadListElement (interp, &readData, elemObj); if (rstat == TCL_OK) { Tcl_ListObjAppendElement (NULL, dataObj, elemObj); } else { Tcl_DecrRefCount (elemObj); } } if (rstat == TCL_ERROR) goto errorExit; /* * Return the string as a result or in a variable. */ if (objc == 2) { Tcl_SetObjResult (interp, dataObj); } else { int resultLen; if (Tcl_ObjSetVar2(interp, objv[2], NULL, dataObj, TCL_PARSE_PART1|TCL_LEAVE_ERR_MSG) == NULL) { goto errorExit; } if (Tcl_Eof (channel) || Tcl_InputBlocked (channel)) { resultLen = -1; } else { /* Adjust length for extra newlines that are inserted */ resultLen = Tcl_DStringLength (&readData.buffer) - 1; } Tcl_SetIntObj (Tcl_GetObjResult (interp), resultLen); } Tcl_DecrRefCount (dataObj); Tcl_DStringFree (&readData.buffer); return TCL_OK; errorExit: /* * If a variable is supplied, return whatever data we have in buffer * that has not been processed. The last bit of data is save as * the last element. This is mostly good for debugging. */ if (objc > 2) { Tcl_Obj *saveResult; int len = Tcl_DStringLength (&readData.buffer) - readData.lineIdx; if (len > 0) { Tcl_ListObjAppendElement ( NULL, dataObj, Tcl_NewStringObj (Tcl_DStringValue (&readData.buffer), len)); } saveResult = Tcl_GetObjResult (interp); Tcl_IncrRefCount (saveResult); /* * Save data in variable, if an error occures, let it be reported * instead of original error. * FIX: Need functions to save/restore error state. */ if (Tcl_ObjSetVar2(interp, objv[2], NULL, dataObj, TCL_PARSE_PART1|TCL_LEAVE_ERR_MSG) != NULL) { Tcl_SetObjResult (interp, saveResult); /* Restore old message */ } Tcl_DecrRefCount (saveResult); } Tcl_DecrRefCount (dataObj); Tcl_DStringFree (&readData.buffer); return TCL_ERROR; } /*----------------------------------------------------------------------------- * TclX_LgetsInit -- * Initialize the lgets command. *----------------------------------------------------------------------------- */ void TclX_LgetsInit (interp) Tcl_Interp *interp; { Tcl_CreateObjCommand (interp, "lgets", TclX_LgetsObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc*) NULL); } tclx8.4-8.4.1.orig/generic/tclXoscmds.c0000644000000000000000000002763612046313170014473 0ustar /* * tclXoscmds.c -- * * Tcl commands to access unix system calls that are portable to other * platforms. *----------------------------------------------------------------------------- * Copyright 1991-1999 Karl Lehenbauer and Mark Diekhans. * * Permission to use, copy, modify, and distribute this software and its * documentation for any purpose and without fee is hereby granted, provided * that the above copyright notice appear in all copies. Karl Lehenbauer and * Mark Diekhans make no representations about the suitability of this * software for any purpose. It is provided "as is" without express or * implied warranty. *----------------------------------------------------------------------------- * $Id: tclXoscmds.c,v 1.1 2001/10/24 23:31:48 hobbs Exp $ *----------------------------------------------------------------------------- */ #include "tclExtdInt.h" static int TclX_AlarmObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int TclX_LinkObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int TclX_NiceObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int TclX_SleepObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int TclX_SyncObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int TclX_SystemObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int TclX_UmaskObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); /*----------------------------------------------------------------------------- * TclX_AlarmObjCmd -- * Implements the TCL Alarm command: * alarm seconds * * Results: * Standard TCL results, may return the UNIX system error message. * *----------------------------------------------------------------------------- */ static int TclX_AlarmObjCmd (clientData, interp, objc, objv) ClientData clientData; Tcl_Interp *interp; int objc; Tcl_Obj *CONST objv[]; { double seconds; if (objc != 2) return TclX_WrongArgs (interp, objv [0], "seconds"); if (Tcl_GetDoubleFromObj (interp, objv[1], &seconds) != TCL_OK) return TCL_ERROR; if (TclXOSsetitimer (interp, &seconds, "alarm") != TCL_OK) return TCL_ERROR; Tcl_SetDoubleObj (Tcl_GetObjResult (interp), seconds); return TCL_OK; } /*----------------------------------------------------------------------------- * TclX_LinkObjCmd -- * Implements the TCL link command: * link ?-sym? srcpath destpath * * Results: * Standard TCL results, may return the UNIX system error message. *----------------------------------------------------------------------------- */ static int TclX_LinkObjCmd (clientData, interp, objc, objv) ClientData clientData; Tcl_Interp *interp; int objc; Tcl_Obj *CONST objv[]; { char *srcPath, *destPath; Tcl_DString srcPathBuf, destPathBuf; char *argv0String; char *srcPathString; char *destPathString; Tcl_DStringInit (&srcPathBuf); Tcl_DStringInit (&destPathBuf); if ((objc < 3) || (objc > 4)) return TclX_WrongArgs (interp, objv [0], "?-sym? srcpath destpath"); if (objc == 4) { char *argv1String = Tcl_GetStringFromObj (objv [1], NULL); if (!STREQU (argv1String, "-sym")) { TclX_AppendObjResult (interp, "invalid option, expected: \"-sym\", got: ", Tcl_GetStringFromObj (objv [1], NULL), (char *) NULL); return TCL_ERROR; } } srcPathString = Tcl_GetStringFromObj (objv [objc - 2], NULL); srcPath = Tcl_TranslateFileName (interp, srcPathString, &srcPathBuf); if (srcPath == NULL) goto errorExit; destPathString = Tcl_GetStringFromObj (objv [objc - 1], NULL); destPath = Tcl_TranslateFileName (interp, destPathString, &destPathBuf); if (destPath == NULL) goto errorExit; argv0String = Tcl_GetStringFromObj (objv [0], NULL); if (objc == 4) { if (TclX_OSsymlink (interp, srcPath, destPath, argv0String) != TCL_OK) goto errorExit; } else { if (TclX_OSlink (interp, srcPath, destPath, argv0String) != TCL_OK) goto errorExit; } Tcl_DStringFree (&srcPathBuf); Tcl_DStringFree (&destPathBuf); return TCL_OK; errorExit: Tcl_DStringFree (&srcPathBuf); Tcl_DStringFree (&destPathBuf); return TCL_ERROR; } /*----------------------------------------------------------------------------- * TclX_NiceObjCmd -- * Implements the TCL nice command: * nice ?priorityincr? * * Results: * Standard TCL results, may return the UNIX system error message. * *----------------------------------------------------------------------------- */ static int TclX_NiceObjCmd (clientData, interp, objc, objv) ClientData clientData; Tcl_Interp *interp; int objc; Tcl_Obj *CONST objv[]; { Tcl_Obj *resultPtr = Tcl_GetObjResult (interp); int priorityIncr, priority; char *argv0String; if (objc > 2) return TclX_WrongArgs (interp, objv [0], "?priorityincr?"); argv0String = Tcl_GetStringFromObj (objv [0], NULL); /* * Return the current priority if an increment is not supplied. */ if (objc == 1) { if (TclXOSgetpriority (interp, &priority, argv0String) != TCL_OK) return TCL_ERROR; Tcl_SetIntObj (Tcl_GetObjResult (interp), priority); return TCL_OK; } /* * Increment the priority. */ if (Tcl_GetIntFromObj (interp, objv [1], &priorityIncr) != TCL_OK) return TCL_ERROR; if (TclXOSincrpriority (interp, priorityIncr, &priority, argv0String) != TCL_OK) return TCL_ERROR; Tcl_SetIntObj (resultPtr, priority); return TCL_OK; } /*----------------------------------------------------------------------------- * TclX_SleepObjCmd -- * Implements the TCL sleep command: * sleep seconds * * Results: * Standard TCL results, may return the UNIX system error message. * *----------------------------------------------------------------------------- */ static int TclX_SleepObjCmd (clientData, interp, objc, objv) ClientData clientData; Tcl_Interp *interp; int objc; Tcl_Obj *CONST objv[]; { double time; if (objc != 2) return TclX_WrongArgs (interp, objv [0], "seconds"); if (Tcl_GetDoubleFromObj (interp, objv [1], &time) != TCL_OK) return TCL_ERROR; TclXOSsleep ((int) time); return TCL_OK; } /*----------------------------------------------------------------------------- * TclX_SyncObjCmd -- * Implements the TCL sync command: * sync * * Results: * Standard TCL results. * *----------------------------------------------------------------------------- */ static int TclX_SyncObjCmd (clientData, interp, objc, objv) ClientData clientData; Tcl_Interp *interp; int objc; Tcl_Obj *CONST objv[]; { Tcl_Channel channel; if ((objc < 1) || (objc > 2)) return TclX_WrongArgs (interp, objv [0], "?filehandle?"); if (objc == 1) { TclXOSsync (); return TCL_OK; } channel = TclX_GetOpenChannelObj (interp, objv [1], TCL_WRITABLE); if (channel == NULL) return TCL_ERROR; if (Tcl_Flush (channel) < 0) { Tcl_SetStringObj (Tcl_GetObjResult (interp), Tcl_PosixError (interp), -1); return TCL_ERROR; } return TclXOSfsync (interp, channel); } /*----------------------------------------------------------------------------- * TclX_SystemObjCmd -- * Implements the TCL system command: * system cmdstr1 ?cmdstr2...? *----------------------------------------------------------------------------- */ static int TclX_SystemObjCmd (clientData, interp, objc, objv) ClientData clientData; Tcl_Interp *interp; int objc; Tcl_Obj *CONST objv[]; { Tcl_Obj *cmdObjPtr; char *cmdStr; int exitCode; if (objc < 2) return TclX_WrongArgs (interp, objv [0], "cmdstr1 ?cmdstr2...?"); cmdObjPtr = Tcl_ConcatObj (objc - 1, &(objv[1])); cmdStr = Tcl_GetStringFromObj (cmdObjPtr, NULL); if (TclXOSsystem (interp, cmdStr, &exitCode) != TCL_OK) { Tcl_DecrRefCount (cmdObjPtr); return TCL_ERROR; } Tcl_SetIntObj (Tcl_GetObjResult (interp), exitCode); Tcl_DecrRefCount (cmdObjPtr); return TCL_OK; } /*----------------------------------------------------------------------------- * TclX_UmaskObjCmd -- * Implements the TCL umask command: * umask ?octalmask? * * Results: * Standard TCL results, may return the UNIX system error message. * *----------------------------------------------------------------------------- */ static int TclX_UmaskObjCmd (clientData, interp, objc, objv) ClientData clientData; Tcl_Interp *interp; int objc; Tcl_Obj *CONST objv[]; { int mask; char *umaskString; char numBuf [32]; if ((objc < 1) || (objc > 2)) return TclX_WrongArgs (interp, objv [0], "?octalmask?"); /* * FIX: Should include leading 0 to make it a legal number. */ if (objc == 1) { mask = umask (0); umask ((unsigned short) mask); sprintf (numBuf, "%o", mask); Tcl_SetStringObj (Tcl_GetObjResult (interp), numBuf, -1); } else { umaskString = Tcl_GetStringFromObj (objv [1], NULL); if (!TclX_StrToInt (umaskString, 8, &mask)) { TclX_AppendObjResult (interp, "Expected octal number got: ", Tcl_GetStringFromObj (objv [1], NULL), (char *) NULL); return TCL_ERROR; } umask ((unsigned short) mask); } return TCL_OK; } /*----------------------------------------------------------------------------- * TclX_OsCmdsInit -- * Initialize the OS related commands. *----------------------------------------------------------------------------- */ void TclX_OsCmdsInit (interp) Tcl_Interp *interp; { Tcl_CreateObjCommand (interp, "alarm", TclX_AlarmObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc*) NULL); Tcl_CreateObjCommand (interp, "link", TclX_LinkObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc*) NULL); Tcl_CreateObjCommand (interp, "nice", TclX_NiceObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc*) NULL); TclX_CreateObjCommand (interp, "sleep", TclX_SleepObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc*) NULL, 0); Tcl_CreateObjCommand (interp, "sync", TclX_SyncObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc*) NULL); TclX_CreateObjCommand (interp, "system", TclX_SystemObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc*) NULL, 0); Tcl_CreateObjCommand (interp, "umask", TclX_UmaskObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc*) NULL); } tclx8.4-8.4.1.orig/generic/tclXsignal.c0000644000000000000000000014271212046313170014451 0ustar /* * tclXsignal.c -- * * Tcl Unix signal support routines and the signal and commands. The #ifdefs * around several common Unix signals existing are for Windows. *----------------------------------------------------------------------------- * Copyright 1991-1999 Karl Lehenbauer and Mark Diekhans. * * Permission to use, copy, modify, and distribute this software and its * documentation for any purpose and without fee is hereby granted, provided * that the above copyright notice appear in all copies. Karl Lehenbauer and * Mark Diekhans make no representations about the suitability of this * software for any purpose. It is provided "as is" without express or * implied warranty. *----------------------------------------------------------------------------- * $Id: tclXsignal.c,v 1.3 2005/02/04 01:34:01 hobbs Exp $ *----------------------------------------------------------------------------- */ #include "tclExtdInt.h" /* * If either SIGCLD or SIGCHLD are defined, define them both. This makes * the interchangeable. Windows doesn't have this signal. */ #if defined(SIGCLD) || defined(SIGCHLD) # ifndef SIGCLD # define SIGCLD SIGCHLD # endif # ifndef SIGCHLD # define SIGCHLD SIGCLD # endif #endif #ifndef MAXSIG # ifdef NSIG # define MAXSIG NSIG # else # define MAXSIG 32 # endif #endif /* * Encore UMAX doesn't define SIG_ERR!. */ #ifndef SIG_ERR # define SIG_ERR (void (*)())-1 #endif /* * Value returned by Tcl_SignalId when an invalid signal is passed in. * Pointer is used as a quick check of a valid signal number. */ static CONST char *unknownSignalIdMsg; /* * Signal name table maps name to number. Note, it is possible to have * more than MAXSIG entries in this table if the system defines multiple * symbols that have the same value. */ #define SIG_NAME_MAX 9 /* Maximum length of any signal name */ static struct { char *name; short num; } sigNameTable [] = { #ifdef SIGABRT {"ABRT", SIGABRT}, #endif #ifdef SIGALRM {"ALRM", SIGALRM}, #endif #ifdef SIGBUS {"BUS", SIGBUS}, #endif #ifdef SIGCHLD {"CHLD", SIGCHLD}, #endif #ifdef SIGCLD {"CLD", SIGCLD}, #endif #ifdef SIGCONT {"CONT", SIGCONT}, #endif #ifdef SIGEMT {"EMT", SIGEMT}, #endif #ifdef SIGFPE {"FPE", SIGFPE}, #endif #ifdef SIGHUP {"HUP", SIGHUP}, #endif #ifdef SIGILL {"ILL", SIGILL}, #endif #ifdef SIGINT {"INT", SIGINT}, #endif #ifdef SIGIO {"IO", SIGIO}, #endif #ifdef SIGIOT {"IOT", SIGIOT}, #endif #ifdef SIGKILL {"KILL", SIGKILL}, #endif #ifdef SIGLOST {"LOST", SIGLOST}, #endif #ifdef SIGPIPE {"PIPE", SIGPIPE}, #endif #ifdef SIGPOLL {"POLL", SIGPOLL}, #endif #ifdef SIGPROF {"PROF", SIGPROF}, #endif #ifdef SIGPWR {"PWR", SIGPWR}, #endif #ifdef SIGQUIT {"QUIT", SIGQUIT}, #endif #ifdef SIGSEGV {"SEGV", SIGSEGV}, #endif #ifdef SIGSTOP {"STOP", SIGSTOP}, #endif #ifdef SIGSYS {"SYS", SIGSYS}, #endif #ifdef SIGTERM {"TERM", SIGTERM}, #endif #ifdef SIGTRAP {"TRAP", SIGTRAP}, #endif #ifdef SIGTSTP {"TSTP", SIGTSTP}, #endif #ifdef SIGTTIN {"TTIN", SIGTTIN}, #endif #ifdef SIGTTOU {"TTOU", SIGTTOU}, #endif #ifdef SIGURG {"URG", SIGURG}, #endif #ifdef SIGUSR1 {"USR1", SIGUSR1}, #endif #ifdef SIGUSR2 {"USR2", SIGUSR2}, #endif #ifdef SIGVTALRM {"VTALRM", SIGVTALRM}, #endif #ifdef SIGWINCH {"WINCH", SIGWINCH}, #endif #ifdef SIGXCPU {"XCPU", SIGXCPU}, #endif #ifdef SIGXFSZ {"XFSZ", SIGXFSZ}, #endif {NULL, -1}}; #ifndef RETSIGTYPE # define RETSIGTYPE void #endif typedef RETSIGTYPE (*signalProcPtr_t) _ANSI_ARGS_((int)); /* * Defines if this is not Posix. */ #ifndef SIG_BLOCK # define SIG_BLOCK 1 # define SIG_UNBLOCK 2 #endif /* * SunOS has sigaction but uses SA_INTERRUPT rather than SA_RESTART which * has the opposite meaning. */ #ifndef NO_SIGACTION #if defined(SA_INTERRUPT) && !defined(SA_RESTART) #define USE_SA_INTERRUPT #endif #endif /* * Symbolic signal actions that can be associated with a signal. */ static char *SIGACT_DEFAULT = "default"; static char *SIGACT_IGNORE = "ignore"; static char *SIGACT_ERROR = "error"; static char *SIGACT_TRAP = "trap"; static char *SIGACT_UNKNOWN = "unknown"; static Tcl_Interp **interpTable = NULL; static Tcl_AsyncHandler asyncHandler = NULL; static int interpTableSize = 0; static int numInterps = 0; /* * Application signal error handler. Called after normal signal processing, * when a signal results in an error. Its main purpose in life is to allow * interactive command loops to clear their input buffer on SIGINT. This is * not currently a generic interface, but should be. Only one maybe active. */ static TclX_AppSignalErrorHandler appSigErrorHandler = NULL; static ClientData appSigErrorClientData = NULL; /* * Counters of signals that have occured but have not been processed. */ static unsigned signalsReceived[MAXSIG]; /* * Table of commands to evaluate when a signal occurs. If the command is * NULL and the signal is received, an error is returned. */ static char *signalTrapCmds[MAXSIG]; /* * Prototypes of internal functions. */ static CONST84 char * GetSignalName _ANSI_ARGS_((int signalNum)); static int GetSignalState _ANSI_ARGS_((int signalNum, signalProcPtr_t *sigProcPtr, int *restart)); static int SetSignalState _ANSI_ARGS_((int signalNum, signalProcPtr_t sigFunc, int restart)); static int BlockSignals _ANSI_ARGS_((Tcl_Interp *interp, int action, unsigned char signals [MAXSIG])); static Tcl_Obj * SignalBlocked _ANSI_ARGS_((int signalNum)); static int SigNameToNum _ANSI_ARGS_((Tcl_Interp *interp, char *sigName, int *sigNumPtr)); static int ParseSignalSpec _ANSI_ARGS_((Tcl_Interp *interp, char *signalStr, int allowZero)); static RETSIGTYPE SignalTrap _ANSI_ARGS_((int signalNum)); static int FormatTrapCode _ANSI_ARGS_((Tcl_Interp *interp, int signalNum, Tcl_DString *command)); static int EvalTrapCode _ANSI_ARGS_((Tcl_Interp *interp, int signalNum)); static int ProcessASignal _ANSI_ARGS_((Tcl_Interp *interp, int background, int signalNum)); static int ProcessSignals _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int cmdResultCode)); static int ParseSignalList _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *signalListObjPtr, unsigned char signals [MAXSIG])); static int SetSignalActions _ANSI_ARGS_((Tcl_Interp *interp, unsigned char signals [MAXSIG], signalProcPtr_t actionFunc, int restart, char *command)); static int FormatSignalListEntry _ANSI_ARGS_((Tcl_Interp *interp, int signalNum, Tcl_Obj *sigStatesObjPtr)); static int ProcessSignalListEntry _ANSI_ARGS_((Tcl_Interp *interp, char *signalName, Tcl_Obj *stateObjPtr)); static int GetSignalStates _ANSI_ARGS_((Tcl_Interp *interp, unsigned char signals [MAXSIG])); static int SetSignalStates _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *sigStatesObjPtr)); static void SignalCmdCleanUp _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp)); static int TclX_SignalObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int TclX_KillObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); /*----------------------------------------------------------------------------- * GetSignalName -- * Get the name for a signal. This normalized SIGCHLD. * Parameters: * o signalNum - Signal number convert. * Results * Static signal name. *----------------------------------------------------------------------------- */ static CONST84 char * GetSignalName (signalNum) int signalNum; { #ifdef SIGCHLD /* * Force name to always be SIGCHLD, even if system defines only SIGCLD. */ if (signalNum == SIGCHLD) return "SIGCHLD"; #endif return Tcl_SignalId (signalNum); } /*----------------------------------------------------------------------------- * GetSignalState -- * Get the current state of the specified signal. * Parameters: * o signalNum - Signal number to query. * o sigProcPtr - The signal function is returned here. * o restart - Restart systems calls on signal. * Results * TCL_OK or TCL_ERROR (check errno). *----------------------------------------------------------------------------- */ static int GetSignalState (signalNum, sigProcPtr, restart) int signalNum; signalProcPtr_t *sigProcPtr; int *restart; { #ifndef NO_SIGACTION struct sigaction currentState; if (sigaction (signalNum, NULL, ¤tState) < 0) return TCL_ERROR; *sigProcPtr = currentState.sa_handler; #ifdef USE_SA_INTERRUPT *restart = ((currentState.sa_flags & SA_INTERRUPT) == 0); #else *restart = ((currentState.sa_flags & SA_RESTART) != 0); #endif return TCL_OK; #else signalProcPtr_t actionFunc; #ifdef SIGKILL if (signalNum == SIGKILL) { *sigProcPtr = SIG_DFL; return TCL_OK; } #endif actionFunc = signal (signalNum, SIG_DFL); if (actionFunc == SIG_ERR) return TCL_ERROR; if (actionFunc != SIG_DFL) signal (signalNum, actionFunc); /* reset */ *sigProcPtr = actionFunc; restart = FALSE; return TCL_OK; #endif } /*----------------------------------------------------------------------------- * SetSignalState -- * Set the state of a signal. * Parameters: * o signalNum - Signal number to query. * o sigFunc - The signal function or SIG_DFL or SIG_IGN. * o restart - Restart systems calls on signal. * Results * TCL_OK or TCL_ERROR (check errno). *----------------------------------------------------------------------------- */ static int SetSignalState (signalNum, sigFunc, restart) int signalNum; signalProcPtr_t sigFunc; int restart; { #ifndef NO_SIGACTION struct sigaction newState; newState.sa_handler = sigFunc; sigfillset (&newState.sa_mask); newState.sa_flags = 0; #ifdef USE_SA_INTERRUPT if (!restart) { newState.sa_flags |= SA_INTERRUPT; } #else if (restart) { newState.sa_flags |= SA_RESTART; } #endif if (sigaction (signalNum, &newState, NULL) < 0) return TCL_ERROR; return TCL_OK; #else if (signal (signalNum, sigFunc) == SIG_ERR) return TCL_ERROR; else return TCL_OK; #endif } /*----------------------------------------------------------------------------- * BlockSignals -- * * Block or unblock the specified signals. Returns an error if not a Posix * system. * * Parameters:: * o interp - Error messages are returned in result. * o action - SIG_BLOCK or SIG_UNBLOCK. * o signals - Boolean array indexed by signal number that indicates * the requested signals. * Returns: * TCL_OK or TCL_ERROR, with error message in interp. *----------------------------------------------------------------------------- */ static int BlockSignals (interp, action, signals) Tcl_Interp *interp; int action; unsigned char signals []; { #ifndef NO_SIGACTION int signalNum; sigset_t sigBlockSet; sigemptyset (&sigBlockSet); for (signalNum = 0; signalNum < MAXSIG; signalNum++) { if (signals [signalNum]) sigaddset (&sigBlockSet, signalNum); } if (sigprocmask (action, &sigBlockSet, NULL)) { TclX_AppendObjResult (interp, Tcl_PosixError (interp), (char *) NULL); return TCL_ERROR; } return TCL_OK; #else TclX_AppendObjResult (interp, "Posix signals are not available on this system, ", "can not block signals"); return TCL_ERROR; #endif } /*----------------------------------------------------------------------------- * SignalBlocked -- * * Determine if a signal is blocked. On non-Posix systems, always returns * FALSE. * * Parameters:: * o signalNum - The signal to determine the state for. * Returns: * NULL if an error occured (with error in errno), otherwise a pointer to a * boolean object. *----------------------------------------------------------------------------- */ static Tcl_Obj * SignalBlocked (signalNum) int signalNum; { #ifndef NO_SIGACTION sigset_t sigBlockSet; if (sigprocmask (SIG_BLOCK, NULL, &sigBlockSet)) { return NULL; } return Tcl_NewBooleanObj (sigismember (&sigBlockSet, signalNum)); #else return Tcl_NewBooleanObj (FALSE); #endif } /*----------------------------------------------------------------------------- * SigNameToNum -- * Converts a UNIX signal name to its number, returns -1 if not found. * the name may be upper or lower case and may optionally have the leading * "SIG" omitted. * * Parameters: * o interp - Errors are returned in result. * o sigName - Name of signal to convert. * o sigNumPtr - Signal number is returned here. * Returns: * TCL_OK or TCL_ERROR. *----------------------------------------------------------------------------- */ static int SigNameToNum (interp, sigName, sigNumPtr) Tcl_Interp *interp; char *sigName; int *sigNumPtr; { char sigNameUp [SIG_NAME_MAX+1]; /* Upshifted signal name */ char *sigNamePtr; int idx; /* * Copy and upshift requested name. */ if (strlen (sigName) > SIG_NAME_MAX) goto invalidSignal; /* Name too long */ TclX_UpShift (sigNameUp, sigName); if (STRNEQU (sigNameUp, "SIG", 3)) sigNamePtr = &sigNameUp [3]; else sigNamePtr = sigNameUp; for (idx = 0; sigNameTable [idx].num != -1; idx++) { if (STREQU (sigNamePtr, sigNameTable [idx].name)) { *sigNumPtr = sigNameTable [idx].num; return TCL_OK; } } invalidSignal: TclX_AppendObjResult (interp, "invalid signal \"", sigName, "\"", (char *) NULL); return TCL_ERROR; } /*----------------------------------------------------------------------------- * ParseSignalSpec -- * * Parse a signal specified as either a name or a number. * * Parameters: * o interp - Interpreter for returning errors. * o signalStr - The signal name or number string. * o allowZero - Allow zero as a valid signal number (for kill). * Returns: * The signal number converted, or -1 if an error occures. *----------------------------------------------------------------------------- */ static int ParseSignalSpec (interp, signalStr, allowZero) Tcl_Interp *interp; char *signalStr; int allowZero; { int signalNum; /* * If its a number, validate that number is actual a valid signal number * for this system. If either fail, try it as a name. Just let * SigNameToNum generate the error message if its a number, but not a * valid signal. */ if (TclX_StrToInt (signalStr, 0, &signalNum)) { if (allowZero && (signalNum == 0)) return 0; if (Tcl_SignalId (signalNum) != unknownSignalIdMsg) return signalNum; } if (SigNameToNum (interp, signalStr, &signalNum) != TCL_OK) return -1; return signalNum; } /*----------------------------------------------------------------------------- * SignalTrap -- * * Trap handler for UNIX signals. Sets tells all registered interpreters * that a trap has occured and saves the trap info. The first interpreter to * call it's async signal handler will process all pending signals. *----------------------------------------------------------------------------- */ static RETSIGTYPE SignalTrap (signalNum) int signalNum; { if (asyncHandler == NULL) return; /* * Record the count of the number of this type of signal that has occured * and tell all the interpreters to call the async handler when safe. */ signalsReceived [signalNum]++; Tcl_AsyncMark (asyncHandler); #ifdef NO_SIGACTION /* * For old-style Unix signals, the signal must be explictly re-enabled. * Not done for SIGCHLD, as we would continue to the signal until the * wait is done. This is fixed by Posix signals and is not necessary under * BSD, but it done this way for consistency. */ #ifdef SIGCHLD if (signalNum != SIGCHLD) { if (SetSignalState (signalNum, SignalTrap, FALSE) == TCL_ERROR) panic ("SignalTrap bug"); } #else if (SetSignalState (signalNum, SignalTrap, FALSE) == TCL_ERROR) panic ("SignalTrap bug"); #endif /* SIGCHLD */ #endif /* NO_SIGACTION */ } /*----------------------------------------------------------------------------- * FormatTrapCode -- * Format the signal name into the signal trap command. Replacing %S with * the signal name. * * Parameters: * o interp (I/O) - The interpreter to return errors in. * o signalNum - The signal number of the signal that occured. * o command - The resulting command adter the formatting. *----------------------------------------------------------------------------- */ static int FormatTrapCode (interp, signalNum, command) Tcl_Interp *interp; int signalNum; Tcl_DString *command; { char *copyPtr, *scanPtr; Tcl_DStringInit (command); copyPtr = scanPtr = signalTrapCmds [signalNum]; while (*scanPtr != '\0') { if (*scanPtr != '%') { scanPtr++; continue; } if (scanPtr [1] == '%') { scanPtr += 2; continue; } Tcl_DStringAppend (command, copyPtr, (scanPtr - copyPtr)); switch (scanPtr [1]) { case 'S': { Tcl_DStringAppend (command, GetSignalName (signalNum), -1); break; } default: goto badSpec; } scanPtr += 2; copyPtr = scanPtr; } Tcl_DStringAppend (command, copyPtr, copyPtr - scanPtr); return TCL_OK; /* * Handle bad % specification currently pointed to by scanPtr. */ badSpec: { char badSpec [2]; badSpec [0] = scanPtr [1]; badSpec [1] = '\0'; TclX_AppendObjResult (interp, "bad signal trap command formatting ", "specification \"%", badSpec, "\", expected one of \"%%\" or \"%S\"", (char *) NULL); return TCL_ERROR; } } /*----------------------------------------------------------------------------- * EvalTrapCode -- * Run code as the result of a signal. The symbolic signal name is * formatted into the command replacing %S with the symbolic signal name. * * Parameters: * o interp - The interpreter to run the signal in. If an error * occures, then the result will be left in the interp. * o signalNum - The signal number of the signal that occured. * Return: * TCL_OK or TCL_ERROR. *----------------------------------------------------------------------------- */ static int EvalTrapCode (interp, signalNum) Tcl_Interp *interp; int signalNum; { int result; Tcl_DString command; Tcl_Obj *saveObjPtr; saveObjPtr = TclX_SaveResultErrorInfo (interp); Tcl_ResetResult (interp); /* * Format the signal name into the command. This also allows the signal * to be reset in the command. */ result = FormatTrapCode (interp, signalNum, &command); if (result == TCL_OK) result = Tcl_GlobalEval (interp, command.string); Tcl_DStringFree (&command); if (result == TCL_ERROR) { char errorInfo [128]; sprintf (errorInfo, "\n while executing signal trap code for %s%s", Tcl_SignalId (signalNum), " signal"); Tcl_AddErrorInfo (interp, errorInfo); return TCL_ERROR; } TclX_RestoreResultErrorInfo (interp, saveObjPtr); return TCL_OK; } /*----------------------------------------------------------------------------- * ProcessASignal -- * * Do processing on the specified signal. * * Parameters: * o interp - Result will contain the result of the signal handling * code that was evaled. * o background - Signal handler was called from the event loop with * no current interp. * o signalNum - The signal to process. * Returns: * TCL_OK or TCL_ERROR. *----------------------------------------------------------------------------- */ static int ProcessASignal (interp, background, signalNum) Tcl_Interp *interp; int background; int signalNum; { int result = TCL_OK; /* * Either return an error or evaluate code associated with this signal. * If evaluating code, call it for each time the signal occured. */ if (signalTrapCmds [signalNum] == NULL) { CONST84 char *signalName = GetSignalName (signalNum); signalsReceived [signalNum] = 0; Tcl_SetErrorCode (interp, "POSIX", "SIG", signalName, (char*) NULL); TclX_AppendObjResult (interp, signalName, " signal received", (char *)NULL); Tcl_SetVar (interp, "errorInfo", "", TCL_GLOBAL_ONLY); result = TCL_ERROR; /* * Let the application at signals that generate errors. */ if (appSigErrorHandler != NULL) result = (*appSigErrorHandler) (interp, appSigErrorClientData, background, signalNum); } else { while (signalsReceived [signalNum] > 0) { (signalsReceived [signalNum])--; result = EvalTrapCode (interp, signalNum); if (result == TCL_ERROR) break; } } return result; } /*----------------------------------------------------------------------------- * ProcessSignals -- * * Called by the async handler to process pending signals in a safe state * interpreter state. This is often called just after a command completes. * The results of the command are passed to this procedure and may be altered * by it. If trap code is specified for the signal that was received, then * the trap will be executed, otherwise an error result will be returned * indicating that the signal occured. If an error is returned, clear the * errorInfo variable. This makes sure it exists and that it is empty, * otherwise bogus or non-existant information will be returned if this * routine was called somewhere besides Tcl_Eval. If a signal was received * multiple times and a trap is set on it, then that trap will be executed for * each time the signal was received. * * Parameters: * o clientData - Not used. * o interp (I/O) - interp result should contain the result for * the command that just executed. This will either be restored or * replaced with a new result. If this is NULL, then no interpreter * is directly available (i.e. event loop). In this case, the first * interpreter in internal interpreter table is used. If an error results * from signal processing, it is handled via Tcl_BackgroundError. * o cmdResultCode - The integer result returned by the command that * Tcl_Eval just completed. Should be TCL_OK if not called from * Tcl_Eval. * Returns: * Either the original result code, an error result if one of the * trap commands returned an error, or an error indicating the * a signal occured. *----------------------------------------------------------------------------- */ static int ProcessSignals (clientData, interp, cmdResultCode) ClientData clientData; Tcl_Interp *interp; int cmdResultCode; { Tcl_Interp *sigInterp; Tcl_Obj *errStateObjPtr; int signalNum, result; /* * Get the interpreter if it wasn't supplied, if none is available, * bail out. */ if (interp == NULL) { if (numInterps == 0) return cmdResultCode; sigInterp = interpTable [0]; } else { sigInterp = interp; } errStateObjPtr = TclX_SaveResultErrorInfo (sigInterp); /* * Process all signals. Don't process any more if one returns an error. */ result = TCL_OK; for (signalNum = 1; signalNum < MAXSIG; signalNum++) { if (signalsReceived [signalNum] == 0) continue; result = ProcessASignal (sigInterp, (interp == NULL), signalNum); if (result == TCL_ERROR) break; } /* * Restore result and error state if we didn't get an error in signal * handling. */ if (result != TCL_ERROR) { TclX_RestoreResultErrorInfo (sigInterp, errStateObjPtr) ; } else { Tcl_DecrRefCount (errStateObjPtr); cmdResultCode = TCL_ERROR; } /* * Reset the signal received flag in case more signals are pending. */ for (signalNum = 1; signalNum < MAXSIG; signalNum++) { if (signalsReceived [signalNum] != 0) break; } if (signalNum < MAXSIG) { if (asyncHandler) Tcl_AsyncMark (asyncHandler); } /* * If a signal handler returned an error and an interpreter was not * supplied, call the background error handler. */ if ((result == TCL_ERROR) && (interp == NULL)) { Tcl_BackgroundError (sigInterp); } return cmdResultCode; } /*----------------------------------------------------------------------------- * ParseSignalList -- * * Parse a list of signal names or numbers. Also handles the special case * of the signal being a single entry of "*". * * Parameters: * o interp - Interpreter for returning errors. * o signalListObjPtr - The Tcl list object of signals to convert. * o signals - Boolean array indexed by signal number that indicates * which signals are set. * Returns: * TCL_OK or TCL_ERROR. *----------------------------------------------------------------------------- */ static int ParseSignalList (interp, signalListObjPtr, signals) Tcl_Interp *interp; Tcl_Obj *signalListObjPtr; unsigned char signals [MAXSIG]; { Tcl_Obj **signalObjv; char *signalStr; int signalObjc, signalNum, idx, cnt; if (Tcl_ListObjGetElements (interp, signalListObjPtr, &signalObjc, &signalObjv) != TCL_OK) return TCL_ERROR; if (signalObjc == 0) { TclX_AppendObjResult (interp, "signal list may not be empty", (char *) NULL); return TCL_ERROR; } memset (signals, FALSE, sizeof (unsigned char) * MAXSIG); /* * Handle the wild card signal. Don't return signals that can't be * modified. */ signalStr = Tcl_GetStringFromObj (signalObjv [0], NULL); if (STREQU (signalStr, "*")) { if (signalObjc != 1) goto wildMustBeAlone; cnt = 0; for (idx = 0; sigNameTable [idx].name != NULL; idx++) { signalNum = sigNameTable [idx].num; #ifdef SIGKILL if ((signalNum == SIGKILL) || (signalNum == SIGSTOP)) continue; #endif signals [signalNum] = TRUE; } goto okExit; } /* * Handle individually specified signals. */ for (idx = 0; idx < signalObjc; idx++) { signalStr = Tcl_GetStringFromObj (signalObjv [idx], NULL); if (STREQU (signalStr, "*")) goto wildMustBeAlone; signalNum = ParseSignalSpec (interp, signalStr, FALSE); /* Zero not valid */ if (signalNum < 0) return TCL_ERROR; signals [signalNum] = TRUE; } okExit: return TCL_OK; wildMustBeAlone: TclX_AppendObjResult (interp, "when \"*\" is specified in the signal ", "list, no other signals may be specified", (char *) NULL); return TCL_ERROR; } /*----------------------------------------------------------------------------- * SetSignalActions -- * * Set the signal state for the specified signals. * * Parameters:: * o interp - The list is returned in the result. * o signals - Boolean array indexed by signal number that indicates * the requested signals. * o actionFunc - The function to run when the signal is received. * o restart - Restart systems calls on signal. * o command - If the function is the "trap" function, this is the * Tcl command to run when the trap occurs. Otherwise, NULL. * Returns: * TCL_OK or TCL_ERROR, with error message in interp. *----------------------------------------------------------------------------- */ static int SetSignalActions (interp, signals, actionFunc, restart, command) Tcl_Interp *interp; unsigned char signals [MAXSIG]; signalProcPtr_t actionFunc; int restart; char *command; { int signalNum; for (signalNum = 0; signalNum < MAXSIG; signalNum++) { if (!signals [signalNum]) continue; if (signalTrapCmds [signalNum] != NULL) { ckfree (signalTrapCmds [signalNum]); signalTrapCmds [signalNum] = NULL; } if (command != NULL) signalTrapCmds [signalNum] = ckstrdup (command); if (SetSignalState (signalNum, actionFunc, restart) == TCL_ERROR) { TclX_AppendObjResult (interp, Tcl_PosixError (interp), " while setting ", Tcl_SignalId (signalNum), (char *) NULL); return TCL_ERROR; } } return TCL_OK; } /*----------------------------------------------------------------------------- * FormatSignalListEntry -- * * Retrieve a signal's state and format a keyed list entry used to describe * a that state. * * Parameters:: * o interp - Error messages are returned here. * o signalNum - The signal to get the state for. * o sigStatesObjPtr - Keyed list to add entry to. * Returns: * TCL_OK or TCL_ERROR. *----------------------------------------------------------------------------- */ static int FormatSignalListEntry (interp, signalNum, sigStatesObjPtr) Tcl_Interp *interp; int signalNum; Tcl_Obj *sigStatesObjPtr; { Tcl_Obj *stateObjv [4], *stateObjPtr; signalProcPtr_t actionFunc; char *actionStr, *idStr; int restart; if (GetSignalState (signalNum, &actionFunc, &restart) == TCL_ERROR) goto unixSigError; if (actionFunc == SIG_DFL) { actionStr = SIGACT_DEFAULT; } else if (actionFunc == SIG_IGN) { actionStr = SIGACT_IGNORE; } else if (actionFunc == SignalTrap) { if (signalTrapCmds [signalNum] == NULL) { actionStr = SIGACT_ERROR; } else { actionStr = SIGACT_TRAP; } } else { actionStr = SIGACT_UNKNOWN; } stateObjv [1] = SignalBlocked (signalNum); if (stateObjv [1] == NULL) goto unixSigError; stateObjv [0] = Tcl_NewStringObj (actionStr, -1); if (signalTrapCmds [signalNum] != NULL) { stateObjv [2] = Tcl_NewStringObj (signalTrapCmds [signalNum], -1); } else { stateObjv [2] = Tcl_NewStringObj ("", -1); } stateObjv [3] = Tcl_NewBooleanObj(restart); stateObjPtr = Tcl_NewListObj (4, stateObjv); Tcl_IncrRefCount (stateObjPtr); /* * Dup the string so we don't pass a const char to KLSet. */ idStr = ckstrdup(Tcl_SignalId(signalNum)); if (TclX_KeyedListSet (interp, sigStatesObjPtr, idStr, stateObjPtr) != TCL_OK) { ckfree(idStr); Tcl_DecrRefCount (stateObjPtr); return TCL_ERROR; } ckfree(idStr); Tcl_DecrRefCount (stateObjPtr); return TCL_OK; unixSigError: TclX_AppendObjResult (interp, Tcl_PosixError (interp), " while getting ", Tcl_SignalId (signalNum), (char *) NULL); return TCL_ERROR; } /*----------------------------------------------------------------------------- * ProcessSignalListEntry -- * * Parse a keyed list entry used to describe a signal state and set the * signal to that state. If the signal action is specified as "unknown", * it is ignored. * * Parameters:: * o interp - Error messages are returned here. * o signalName - Signal name. * o stateObjPtr - Signal state information from keyed list. * Returns: * TCL_OK or TCL_ERROR; *----------------------------------------------------------------------------- */ static int ProcessSignalListEntry (interp, signalName, stateObjPtr) Tcl_Interp *interp; char *signalName; Tcl_Obj *stateObjPtr; { Tcl_Obj **stateObjv; int stateObjc; char *actionStr, *cmdStr; int signalNum, blocked; signalProcPtr_t actionFunc = NULL; int restart = FALSE; unsigned char signals [MAXSIG]; /* * Get state list. */ if (Tcl_ListObjGetElements (interp, stateObjPtr, &stateObjc, &stateObjv) != TCL_OK) return TCL_ERROR; if (stateObjc < 2 || stateObjc > 4) goto invalidEntry; /* * Parse the signal name and action. */ if (SigNameToNum (interp, signalName, &signalNum) != TCL_OK) return TCL_ERROR; actionStr = Tcl_GetStringFromObj (stateObjv [0], NULL); cmdStr = NULL; if (stateObjc > 2) { cmdStr = Tcl_GetStringFromObj (stateObjv [2], NULL); if (cmdStr[0] == '\0') { cmdStr = NULL; } } if (STREQU (actionStr, SIGACT_DEFAULT)) { actionFunc = SIG_DFL; if (cmdStr != NULL) goto invalidEntry; } else if (STREQU (actionStr, SIGACT_IGNORE)) { actionFunc = SIG_IGN; if (cmdStr != NULL) goto invalidEntry; } else if (STREQU (actionStr, SIGACT_ERROR)) { actionFunc = SignalTrap; if (cmdStr != NULL) goto invalidEntry; } else if (STREQU (actionStr, SIGACT_TRAP)) { actionFunc = SignalTrap; if (cmdStr == NULL) /* Must have command */ goto invalidEntry; } else if (STREQU (actionStr, SIGACT_UNKNOWN)) { if (cmdStr != NULL) goto invalidEntry; return TCL_OK; /* Ignore non-Tcl signals */ } if (Tcl_GetBooleanFromObj (interp, stateObjv [1], &blocked) != TCL_OK) return TCL_ERROR; if (stateObjc > 3) { if (Tcl_GetBooleanFromObj (interp, stateObjv [3], &restart) != TCL_OK) return TCL_ERROR; } memset (signals, FALSE, sizeof (unsigned char) * MAXSIG); signals [signalNum] = TRUE; /* * Set signal actions and handle blocking if its supported on this * system. If the signal is to be blocked, we do it before setting up * the handler. If its to be unblocked, we do it after. */ #ifndef NO_SIGACTION if (blocked) { if (BlockSignals (interp, SIG_BLOCK, signals) != TCL_OK) return TCL_ERROR; } #endif if (SetSignalActions (interp, signals, actionFunc, restart, cmdStr) != TCL_OK) return TCL_ERROR; #ifndef NO_SIGACTION if (!blocked) { if (BlockSignals (interp, SIG_UNBLOCK, signals) != TCL_OK) return TCL_ERROR; } #endif return TCL_OK; invalidEntry: TclX_AppendObjResult (interp, "invalid signal keyed list entry for ", signalName, (char *) NULL); return TCL_ERROR; } /*----------------------------------------------------------------------------- * GetSignalStates -- * * Return a keyed list containing the signal states for the specified * signals. * * Parameters:: * o interp - The list is returned in the result. * o signals - Boolean array indexed by signal number that indicates * the requested signals. * Returns: * TCL_OK or TCL_ERROR, with error message in interp. *----------------------------------------------------------------------------- */ static int GetSignalStates (interp, signals) Tcl_Interp *interp; unsigned char signals [MAXSIG]; { int signalNum; Tcl_Obj *sigStatesObjPtr; sigStatesObjPtr = TclX_NewKeyedListObj (); for (signalNum = 0; signalNum < MAXSIG; signalNum++) { if (!signals [signalNum]) continue; if (FormatSignalListEntry (interp, signalNum, sigStatesObjPtr) != TCL_OK) { Tcl_DecrRefCount (sigStatesObjPtr); return TCL_ERROR; } } Tcl_SetObjResult (interp, sigStatesObjPtr); return TCL_OK; } /*----------------------------------------------------------------------------- * SetSignalStates -- * * Set signal states from keyed list in the format returned by * GetSignalStates. * * Parameters:: * o interp - Errors are returned in the result. * o sigStatesObjPtr - Keyed list to add entry to. * Returns: * TCL_OK or TCL_ERROR, with error message in interp. *----------------------------------------------------------------------------- */ static int SetSignalStates (interp, sigStatesObjPtr) Tcl_Interp *interp; Tcl_Obj *sigStatesObjPtr; { Tcl_Obj *keysListObj, **keysObjv, *stateObjPtr; int keysObjc, idx; char *signalName; if (TclX_KeyedListGetKeys (interp, sigStatesObjPtr, NULL, &keysListObj) != TCL_OK) return TCL_ERROR; if (Tcl_ListObjGetElements (interp, keysListObj, &keysObjc, &keysObjv) != TCL_OK) return TCL_ERROR; for (idx = 0; idx < keysObjc; idx++) { signalName = Tcl_GetStringFromObj (keysObjv [idx], NULL); if (TclX_KeyedListGet (interp, sigStatesObjPtr, signalName, &stateObjPtr) != TCL_OK) return TCL_ERROR; if (ProcessSignalListEntry (interp, signalName, stateObjPtr) != TCL_OK) return TCL_ERROR; } return TCL_OK; } /*----------------------------------------------------------------------------- * TclX_SignalObjCmd -- * Implements the Tcl signal command: * signal action siglist ?command? *----------------------------------------------------------------------------- */ static int TclX_SignalObjCmd (clientData, interp, objc, objv) ClientData clientData; Tcl_Interp *interp; int objc; Tcl_Obj *CONST objv[]; { unsigned char signals [MAXSIG]; char *argStr, *actionStr; int firstArg = 1; int numArgs; int restart = FALSE; while (firstArg < objc) { argStr = Tcl_GetStringFromObj (objv [firstArg], NULL); if (argStr[0] != '-') { break; } if (STREQU (argStr, "-restart")) { restart = TRUE; } else { TclX_AppendObjResult(interp, "invalid option \"", argStr, "\", expected -restart", NULL); return TCL_ERROR; } firstArg++; } numArgs = objc - firstArg; if ((numArgs < 2) || (numArgs > 3)) { TclX_WrongArgs (interp, objv [0], "?-restart? action signalList ?command?"); return TCL_ERROR; } #ifdef NO_SIG_RESTART if (restart) { TclX_AppendObjResult(interp, "restarting of system calls from signals is not available on this system", NULL); return TCL_ERROR; } #endif actionStr = Tcl_GetStringFromObj (objv [firstArg], NULL); /* * Do the specified action on the signals. "set" has a special format * for the signal list, so do it first. */ if (STREQU (actionStr, "set")) { if (numArgs != 2) goto cmdNotValid; return SetSignalStates (interp, objv [firstArg+1]); } if (ParseSignalList (interp, objv [firstArg+1], signals) != TCL_OK) return TCL_ERROR; if (STREQU (actionStr, SIGACT_TRAP)) { if (numArgs != 3) { TclX_AppendObjResult (interp, "command required for ", "trapping signals", (char *) NULL); return TCL_ERROR; } return SetSignalActions (interp, signals, SignalTrap, restart, Tcl_GetStringFromObj (objv [firstArg+2], NULL)); } if (numArgs != 2) goto cmdNotValid; if (STREQU (actionStr, SIGACT_DEFAULT)) { return SetSignalActions (interp, signals, SIG_DFL, restart, NULL); } if (STREQU (actionStr, SIGACT_IGNORE)) { return SetSignalActions (interp, signals, SIG_IGN, restart, NULL); } if (STREQU (actionStr, SIGACT_ERROR)) { return SetSignalActions (interp, signals, SignalTrap, restart, NULL); } if (STREQU (actionStr, "get")) { return GetSignalStates (interp, signals); } if (STREQU (actionStr, "block")) { return BlockSignals (interp, SIG_BLOCK, signals); } if (STREQU (actionStr, "unblock")) { return BlockSignals (interp, SIG_UNBLOCK, signals); } /* * Not a valid action. */ TclX_AppendObjResult (interp, "invalid signal action specified: ", actionStr, ": expected one of \"default\", ", "\"ignore\", \"error\", \"trap\", \"get\", ", "\"set\", \"block\", or \"unblock\"", (char *) NULL); return TCL_ERROR; cmdNotValid: TclX_AppendObjResult (interp, "command may not be ", "specified for \"", actionStr, "\" action", (char *) NULL); return TCL_ERROR; } /*----------------------------------------------------------------------------- * TclX_KillObjCmd -- * Implements the Tcl kill command: * kill ?-pgroup? ?signal? idlist * * Results: * Standard TCL results, may return the UNIX system error message. *----------------------------------------------------------------------------- */ static int TclX_KillObjCmd (clientData, interp, objc, objv) ClientData clientData; Tcl_Interp *interp; int objc; Tcl_Obj *CONST objv[]; { int signalNum, nextArg, idx, procId, procObjc; int pgroup = FALSE; char *cmdStr, *argStr; Tcl_Obj **procObjv; #ifdef SIGTERM # define DEFAULT_KILL_SIGNAL SIGTERM #else # define DEFAULT_KILL_SIGNAL SIGINT #endif if (objc < 2) goto usage; nextArg = 1; argStr = Tcl_GetStringFromObj (objv [nextArg], NULL); if (STREQU (argStr, "-pgroup")) { pgroup = TRUE; nextArg++; } if (((objc - nextArg) < 1) || ((objc - nextArg) > 2)) goto usage; /* * Get the signal. */ if ((objc - nextArg) == 1) { signalNum = DEFAULT_KILL_SIGNAL; } else { argStr = Tcl_GetStringFromObj (objv [nextArg], NULL); signalNum = ParseSignalSpec (interp, argStr, TRUE); /* Allow zero */ if (signalNum < 0) return TCL_ERROR; nextArg++; } if (Tcl_ListObjGetElements (interp, objv [nextArg], &procObjc, &procObjv) != TCL_OK) return TCL_ERROR; cmdStr = Tcl_GetStringFromObj (objv [0], NULL); for (idx = 0; idx < procObjc; idx++) { if (Tcl_GetIntFromObj (interp, procObjv [idx], &procId) != TCL_OK) goto errorExit; if (pgroup) procId = -procId; if (TclXOSkill (interp, procId, signalNum, cmdStr) != TCL_OK) goto errorExit; } return TCL_OK; errorExit: return TCL_ERROR; usage: TclX_WrongArgs (interp, objv [0], "?-pgroup? ?signal? idlist"); return TCL_ERROR; } /*----------------------------------------------------------------------------- * SignalCmdCleanUp -- * * Clean up the signal data structure when an interpreter is deleted. If * this is the last interpreter, clean up all tables. * * Parameters: * o clientData - Not used. * o interp - Interp that is being deleted. *----------------------------------------------------------------------------- */ static void SignalCmdCleanUp (clientData, interp) ClientData clientData; Tcl_Interp *interp; { int idx; for (idx = 0; idx < numInterps; idx++) { if (interpTable [idx] == interp) break; } if (idx == numInterps) panic ("signal interp lost"); interpTable [idx] = interpTable [--numInterps]; /* * If there are no more interpreters, clean everything up. */ if (numInterps == 0) { ckfree ((char *) interpTable); interpTable = NULL; interpTableSize = 0; Tcl_AsyncDelete(asyncHandler); for (idx = 0; idx < MAXSIG; idx++) { if (signalTrapCmds [idx] != NULL) { ckfree (signalTrapCmds [idx]); signalTrapCmds [idx] = NULL; } } } } /*----------------------------------------------------------------------------- * TclX_SetupSigInt -- * Set up SIGINT to the "error" state if the current state is default. * This is done because shells set SIGINT to ignore for background processes * so that they don't die on signals generated by the user at the keyboard. * Tcl only enables SIGINT catching if it is an interactive session. *----------------------------------------------------------------------------- */ void TclX_SetupSigInt () { signalProcPtr_t actionFunc; int restart; if ((GetSignalState (SIGINT, &actionFunc, &restart) == TCL_OK) && (actionFunc == SIG_DFL)) { SetSignalState (SIGINT, SignalTrap, FALSE); } } /*----------------------------------------------------------------------------- * TclX_SetAppSignalErrorHandler -- * * Set the current application signal error handler. This is kind of a * hack. It just saves the handler and client data in globals. * * Parameters: * o errorFunc - Error handling function. * o clientData - Client data to pass to function *----------------------------------------------------------------------------- */ void TclX_SetAppSignalErrorHandler (errorFunc, clientData) TclX_AppSignalErrorHandler errorFunc; ClientData clientData; { appSigErrorHandler = errorFunc; appSigErrorClientData = clientData; } /*----------------------------------------------------------------------------- * TclX_SignalInit -- * Initializes singal handling for a interpreter. *----------------------------------------------------------------------------- */ void TclX_SignalInit (interp) Tcl_Interp *interp; { int idx; /* * If this is the first interpreter, set everything up. */ if (numInterps == 0) { interpTableSize = 4; interpTable = (Tcl_Interp **) ckalloc (sizeof (Tcl_Interp *) * interpTableSize); for (idx = 0; idx < MAXSIG; idx++) { signalsReceived [idx] = 0; signalTrapCmds [idx] = NULL; } asyncHandler = Tcl_AsyncCreate (ProcessSignals, (ClientData) NULL); /* * Get address of "unknown signal" message. */ unknownSignalIdMsg = Tcl_SignalId (20000); } /* * If there is not room in this table for another interp, expand it. */ if (numInterps == interpTableSize) { interpTable = (Tcl_Interp **) ckrealloc((char *)interpTable, sizeof(Tcl_Interp *) * interpTableSize * 2); interpTableSize *= 2; } /* * Add this interpreter to the list and set up a async handler. * Arange for clean up on the interpreter being deleted. */ interpTable [numInterps] = interp; numInterps++; Tcl_CallWhenDeleted (interp, SignalCmdCleanUp, (ClientData) NULL); Tcl_CreateObjCommand (interp, "signal", TclX_SignalObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc*) NULL); Tcl_CreateObjCommand (interp, "kill", TclX_KillObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc*) NULL); } tclx8.4-8.4.1.orig/generic/tclXflock.c0000644000000000000000000002003212046313167014266 0ustar /* * tclXflock.c * * Extended Tcl flock and funlock commands. *----------------------------------------------------------------------------- * Copyright 1991-1999 Karl Lehenbauer and Mark Diekhans. * * Permission to use, copy, modify, and distribute this software and its * documentation for any purpose and without fee is hereby granted, provided * that the above copyright notice appear in all copies. Karl Lehenbauer and * Mark Diekhans make no representations about the suitability of this * software for any purpose. It is provided "as is" without express or * implied warranty. *----------------------------------------------------------------------------- * $Id: tclXflock.c,v 1.1 2001/10/24 23:31:48 hobbs Exp $ *----------------------------------------------------------------------------- */ /* FIX: Need to add an interface to F_GETLK */ #include "tclExtdInt.h" /* * Prototypes of internal functions. */ static int ParseLockUnlockArgs _ANSI_ARGS_((Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[], int argIdx, TclX_FlockInfo *lockInfoPtr)); static int TclX_FlockObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int TclX_FunlockObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); /*----------------------------------------------------------------------------- * ParseLockUnlockArgs -- * * Parse the positional arguments common to both the flock and funlock * commands: * ... fileId ?start? ?length? ?origin? * * Parameters: * o interp - Pointer to the interpreter, errors returned in result. * o objc - Count of arguments supplied to the comment. * o objv - Commant argument vector. * o argIdx - Index of the first common agument to parse. * o access - Set of TCL_READABLE or TCL_WRITABLE or zero to * not do error checking. * o lockInfoPtr - Lock info structure, start, length and whence are * initialized by this routine. The access and block fields should already * be filled in. * Returns: * TCL_OK or TCL_ERROR. *----------------------------------------------------------------------------- */ static int ParseLockUnlockArgs (interp, objc, objv, argIdx, lockInfoPtr) Tcl_Interp *interp; int objc; Tcl_Obj *CONST objv[]; int argIdx; TclX_FlockInfo *lockInfoPtr; { lockInfoPtr->start = 0; lockInfoPtr->len = 0; lockInfoPtr->whence = 0; lockInfoPtr->channel = TclX_GetOpenChannelObj (interp, objv [argIdx], lockInfoPtr->access); if (lockInfoPtr->channel == NULL) return TCL_ERROR; argIdx++; if ((argIdx < objc) && !TclX_IsNullObj (objv [argIdx])) { if (TclX_GetOffsetFromObj (interp, objv [argIdx], &lockInfoPtr->start) != TCL_OK) return TCL_ERROR; } argIdx++; if ((argIdx < objc) && !TclX_IsNullObj (objv [argIdx])) { if (TclX_GetOffsetFromObj (interp, objv [argIdx], &lockInfoPtr->len) != TCL_OK) return TCL_ERROR; } argIdx++; if (argIdx < objc) { char *originStr = Tcl_GetStringFromObj (objv [argIdx], NULL); if (STREQU (originStr, "start")) { lockInfoPtr->whence = 0; } else if (STREQU (originStr, "current")) { lockInfoPtr->whence = 1; } else if (STREQU (originStr, "end")) { lockInfoPtr->whence = 2; } else { TclX_AppendObjResult (interp, "bad origin \"", originStr, "\": should be \"start\", \"current\", ", "or \"end\"", (char *) NULL); return TCL_ERROR; } } return TCL_OK; } /*----------------------------------------------------------------------------- * TclX_FlockCmd -- * * Implements the `flock' Tcl command: * flock ?-read|-write? ?-nowait? fileId ?start? ?length? ?origin? *----------------------------------------------------------------------------- */ static int TclX_FlockObjCmd (clientData, interp, objc, objv) ClientData clientData; Tcl_Interp *interp; int objc; Tcl_Obj *CONST objv[]; { int argIdx; TclX_FlockInfo lockInfo; if (objc < 2) goto invalidArgs; lockInfo.access = 0; lockInfo.block = TRUE; /* * Parse off the options. */ for (argIdx = 1; argIdx < objc; argIdx++) { char *optStr = Tcl_GetStringFromObj (objv [argIdx], NULL); if (optStr [0] != '-') break; if (STREQU (optStr, "-read")) { lockInfo.access |= TCL_READABLE; continue; } if (STREQU (optStr, "-write")) { lockInfo.access |= TCL_WRITABLE; continue; } if (STREQU (optStr, "-nowait")) { lockInfo.block = FALSE; continue; } TclX_AppendObjResult (interp, "invalid option \"", optStr, "\" expected one of \"-read\", \"-write\", or ", "\"-nowait\"", (char *) NULL); return TCL_ERROR; } if (lockInfo.access == (TCL_READABLE | TCL_WRITABLE)) { TclX_AppendObjResult (interp, "can not specify both \"-read\" and \"-write\"", (char *) NULL); return TCL_ERROR; } if (lockInfo.access == 0) lockInfo.access = TCL_WRITABLE; /* * Make sure there are enough arguments left and then parse the * positional ones. */ if ((argIdx > objc - 1) || (argIdx < objc - 4)) goto invalidArgs; if (ParseLockUnlockArgs (interp, objc, objv, argIdx, &lockInfo) != TCL_OK) return TCL_ERROR; if (TclXOSFlock (interp, &lockInfo) != TCL_OK) return TCL_ERROR; if (!lockInfo.block) { Tcl_SetBooleanObj (Tcl_GetObjResult (interp), lockInfo.gotLock); } return TCL_OK; /* * Code to return error messages. */ invalidArgs: return TclX_WrongArgs (interp, objv [0], "?-read|-write? ?-nowait? fileId ?start? ?length? ?origin?"); } /*----------------------------------------------------------------------------- * TclX_FunlockCmd -- * * Implements the `funlock' Tcl command: * funlock fileId ?start? ?length? ?origin? *----------------------------------------------------------------------------- */ static int TclX_FunlockObjCmd (clientData, interp, objc, objv) ClientData clientData; Tcl_Interp *interp; int objc; Tcl_Obj *CONST objv[]; { TclX_FlockInfo lockInfo; if ((objc < 2) || (objc > 5)) { return TclX_WrongArgs (interp, objv [0], "fileId ?start? ?length? ?origin?"); } lockInfo.access = 0; /* Read or write */ if (ParseLockUnlockArgs (interp, objc, objv, 1, &lockInfo) != TCL_OK) return TCL_ERROR; return TclXOSFunlock (interp, &lockInfo); } /*----------------------------------------------------------------------------- * TclX_FlockInit -- * Initialize the flock and funlock command. *----------------------------------------------------------------------------- */ void TclX_FlockInit (interp) Tcl_Interp *interp; { Tcl_CreateObjCommand (interp, "flock", TclX_FlockObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc*) NULL); Tcl_CreateObjCommand (interp, "funlock", TclX_FunlockObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc*) NULL); } tclx8.4-8.4.1.orig/generic/tclXlist.c0000644000000000000000000004326312046313170014150 0ustar /* * tclXlist.c -- * * Extended Tcl list commands. *----------------------------------------------------------------------------- * Copyright 1991-1999 Karl Lehenbauer and Mark Diekhans. * * Permission to use, copy, modify, and distribute this software and its * documentation for any purpose and without fee is hereby granted, provided * that the above copyright notice appear in all copies. Karl Lehenbauer and * Mark Diekhans make no representations about the suitability of this * software for any purpose. It is provided "as is" without express or * implied warranty. *----------------------------------------------------------------------------- * $Id: tclXlist.c,v 1.2 2005/11/17 23:56:21 hobbs Exp $ *----------------------------------------------------------------------------- */ #include "tclExtdInt.h" /* FIX: Need way to get lvarpush to append to end, or even fill in empty entries */ static int TclX_LvarcatObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int TclX_LvarpopObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int TclX_LvarpushObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int TclX_LemptyObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int TclX_LassignObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int TclX_LmatchObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int TclX_LcontainObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); /*----------------------------------------------------------------------------- * TclX_LvarcatObjCmd -- * Implements the TclX lvarcat command: * lvarcat var string ?string...? *----------------------------------------------------------------------------- */ static int TclX_LvarcatObjCmd (clientData, interp, objc, objv) ClientData clientData; Tcl_Interp *interp; int objc; Tcl_Obj *CONST objv[]; { Tcl_Obj *varObjPtr, *newObjPtr; int catObjc, idx, argIdx; Tcl_Obj **catObjv, *staticObjv [32]; char *varName; if (objc < 3) { return TclX_WrongArgs (interp, objv [0], "var string ?string...?"); } varName = Tcl_GetStringFromObj (objv [1], NULL); catObjv = staticObjv; /* * Get the variable that we are going to update. Include it if it * exists. */ varObjPtr = Tcl_GetVar2Ex(interp, varName, NULL, TCL_PARSE_PART1); if (varObjPtr != NULL) { catObjc = objc - 1; } else { catObjc = objc - 2; } if (catObjc >= (sizeof (staticObjv) / sizeof (char *))) { catObjv = (Tcl_Obj **) ckalloc (catObjc * sizeof (Tcl_Obj *)); } if (varObjPtr != NULL) { catObjv [0] = varObjPtr; argIdx = 1; } else { argIdx = 0; } for (idx = 2; idx < objc; idx++, argIdx++) { catObjv [argIdx] = objv [idx]; } newObjPtr = Tcl_ConcatObj (catObjc, catObjv); if (catObjv != staticObjv) ckfree ((char *) catObjv); if (Tcl_SetVar2Ex(interp, varName, NULL, newObjPtr, TCL_PARSE_PART1|TCL_LEAVE_ERR_MSG) == NULL) { Tcl_DecrRefCount (newObjPtr); return TCL_ERROR; } Tcl_SetObjResult (interp, newObjPtr); return TCL_OK; } /*----------------------------------------------------------------------------- * TclX_LvarpopObjCmd -- * Implements the TclX lvarpop command: * lvarpop var ?indexExpr? ?string? *----------------------------------------------------------------------------- */ static int TclX_LvarpopObjCmd (clientData, interp, objc, objv) ClientData clientData; Tcl_Interp *interp; int objc; Tcl_Obj *CONST objv[]; { Tcl_Obj *listVarPtr, *newVarObj, *returnElemPtr = NULL; int listIdx, listLen; char *varName; if ((objc < 2) || (objc > 4)) { return TclX_WrongArgs (interp, objv [0], "var ?indexExpr? ?string?"); } varName = Tcl_GetStringFromObj (objv [1], NULL); listVarPtr = Tcl_GetVar2Ex(interp, varName, NULL, TCL_PARSE_PART1|TCL_LEAVE_ERR_MSG); if (listVarPtr == NULL) { return TCL_ERROR; } if (Tcl_IsShared (listVarPtr)) { listVarPtr = newVarObj = Tcl_DuplicateObj (listVarPtr); } else { newVarObj = NULL; } /* * Get the index of the entry in the list we are doing to replace/delete. * Just ignore out-of bounds requests, like standard Tcl. */ if (Tcl_ListObjLength (interp, listVarPtr, &listLen) != TCL_OK) goto errorExit; if (objc == 2) { listIdx = 0; } else if (TclX_RelativeExpr (interp, objv [2], listLen, &listIdx) != TCL_OK) { goto errorExit; } if ((listIdx < 0) || (listIdx >= listLen)) { goto okExit; } /* * Get the element that is doing to be deleted/replaced. */ if (Tcl_ListObjIndex (interp, listVarPtr, listIdx, &returnElemPtr) != TCL_OK) goto errorExit; Tcl_IncrRefCount (returnElemPtr); /* * Either replace or delete the element. */ if (objc == 4) { if (Tcl_ListObjReplace (interp, listVarPtr, listIdx, 1, 1, &(objv [3])) != TCL_OK) goto errorExit; } else { if (Tcl_ListObjReplace (interp, listVarPtr, listIdx, 1, 0, NULL) != TCL_OK) goto errorExit; } /* * Update variable. */ if (Tcl_SetVar2Ex(interp, varName, NULL, listVarPtr, TCL_PARSE_PART1|TCL_LEAVE_ERR_MSG) == NULL) { goto errorExit; } Tcl_SetObjResult (interp, returnElemPtr); okExit: if (returnElemPtr != NULL) Tcl_DecrRefCount (returnElemPtr); return TCL_OK; errorExit: if (newVarObj != NULL) { Tcl_DecrRefCount (newVarObj); return TCL_ERROR; } if (returnElemPtr != NULL) { Tcl_DecrRefCount (returnElemPtr); } return TCL_ERROR; } /*----------------------------------------------------------------------------- * TclX_LvarpushObjCmd -- * Implements the TclX lvarpush command: * lvarpush var string ?indexExpr? *----------------------------------------------------------------------------- */ static int TclX_LvarpushObjCmd (clientData, interp, objc, objv) ClientData clientData; Tcl_Interp *interp; int objc; Tcl_Obj *CONST objv[]; { Tcl_Obj *listVarPtr, *newVarObj; int listIdx, listLen; char *varName; if ((objc < 3) || (objc > 4)) { return TclX_WrongArgs (interp, objv [0], "var string ?indexExpr?"); } varName = Tcl_GetStringFromObj (objv [1], NULL); listVarPtr = Tcl_GetVar2Ex(interp, varName, NULL, TCL_PARSE_PART1); if ((listVarPtr == NULL) || (Tcl_IsShared (listVarPtr))) { if (listVarPtr == NULL) { listVarPtr = Tcl_NewListObj (0, NULL); } else { listVarPtr = Tcl_DuplicateObj (listVarPtr); } newVarObj = listVarPtr; } else { newVarObj = NULL; } /* * Get the index of the entry in the list we are doing to replace/delete. * Out-of-bounds request go to the start or end, as with most of Tcl * commands. */ if (Tcl_ListObjLength (interp, listVarPtr, &listLen) != TCL_OK) goto errorExit; if (objc == 3) { listIdx = 0; } else if (TclX_RelativeExpr (interp, objv [3], listLen, &listIdx) != TCL_OK) { goto errorExit; } if (listIdx < 0) { listIdx = 0; } else { if (listIdx > listLen) listIdx = listLen; } if (Tcl_ListObjReplace (interp, listVarPtr, listIdx, 0, 1, &(objv [2])) != TCL_OK) goto errorExit; if (Tcl_SetVar2Ex(interp, varName, NULL, listVarPtr, TCL_PARSE_PART1| TCL_LEAVE_ERR_MSG) == NULL) { goto errorExit; } return TCL_OK; errorExit: if (newVarObj != NULL) { Tcl_DecrRefCount (newVarObj); } return TCL_ERROR; } /*----------------------------------------------------------------------------- * TclX_LemptyObjCmd -- * Implements the TclX lempty command: * lempty list *----------------------------------------------------------------------------- */ static int TclX_LemptyObjCmd (clientData, interp, objc, objv) ClientData clientData; Tcl_Interp *interp; int objc; Tcl_Obj *CONST objv[]; { int length; if (objc != 2) { return TclX_WrongArgs (interp, objv [0], "list"); } /* * A null object. */ if ((objv[1]->typePtr == NULL) && (objv[1]->bytes == NULL)) { Tcl_SetBooleanObj(Tcl_GetObjResult(interp), TRUE); return TCL_OK; } /* * This is a little tricky, because the pre-object lempty never checked * for a valid list, it just checked for a string of all white spaces. * Pass a NULL interp and ignore errors - any thrown are for invalid list * formats, which we accept to be !empty. */ length = 1; Tcl_ListObjLength(NULL, objv[1], &length); Tcl_SetBooleanObj (Tcl_GetObjResult (interp), (0 == length)); return TCL_OK; } /*----------------------------------------------------------------------------- * TclX_LassignObjCmd -- * Implements the TclX assign_fields command: * lassign list varname ?varname...? *----------------------------------------------------------------------------- */ static int TclX_LassignObjCmd (clientData, interp, objc, objv) ClientData clientData; Tcl_Interp *interp; int objc; Tcl_Obj *CONST objv[]; { int listObjc, listIdx, idx, remaining; Tcl_Obj **listObjv, *elemPtr, *remainingObjPtr; Tcl_Obj *nullObjPtr = NULL; if (objc < 3) { return TclX_WrongArgs (interp, objv [0], "list varname ?varname..?"); } if (Tcl_ListObjGetElements (interp, objv [1], &listObjc, &listObjv) != TCL_OK) return TCL_ERROR; /* * Assign elements to specified variables. If there are not enough * elements, set the variables to a NULL object. */ for (idx = 2, listIdx = 0; idx < objc; idx++, listIdx++) { if (listIdx < listObjc) { elemPtr = listObjv [listIdx]; } else { if (nullObjPtr == NULL) { nullObjPtr = Tcl_NewObj (); Tcl_IncrRefCount (nullObjPtr); } elemPtr = nullObjPtr; } if (Tcl_SetVar2Ex(interp, Tcl_GetStringFromObj(objv [idx], NULL), NULL, elemPtr, TCL_PARSE_PART1 | TCL_LEAVE_ERR_MSG) == NULL) goto error_exit; } /* * Return remaining elements as a list. */ remaining = listObjc - objc + 2; if (remaining > 0) { remainingObjPtr = Tcl_NewListObj (remaining, &(listObjv [objc - 2])); Tcl_SetObjResult (interp, remainingObjPtr); } if (nullObjPtr != NULL) Tcl_DecrRefCount (nullObjPtr); return TCL_OK; error_exit: if (nullObjPtr != NULL) Tcl_DecrRefCount (nullObjPtr); return TCL_ERROR; } /*----------------------------------------------------------------------------- * TclX_LmatchObjCmd -- * Implements the TclX lmatch command: * lmatch ?-exact|-glob|-regexp? list pattern *----------------------------------------------------------------------------- */ static int TclX_LmatchObjCmd (clientData, interp, objc, objv) ClientData clientData; Tcl_Interp *interp; int objc; Tcl_Obj *CONST objv[]; { #define EXACT 0 #define GLOB 1 #define REGEXP 2 int listObjc, idx, match, mode, patternLen, valueLen; char *modeStr, *patternStr, *valueStr; Tcl_Obj **listObjv, *matchedListPtr = NULL; mode = GLOB; if (objc == 4) { modeStr = Tcl_GetStringFromObj (objv [1], NULL); if (STREQU (modeStr, "-exact")) { mode = EXACT; } else if (STREQU (modeStr, "-glob")) { mode = GLOB; } else if (STREQU (modeStr, "-regexp")) { mode = REGEXP; } else { TclX_AppendObjResult (interp, "bad search mode \"", modeStr, "\": must be -exact, -glob, or -regexp", (char *) NULL); return TCL_ERROR; } } else if (objc != 3) { return TclX_WrongArgs (interp, objv [0], "?mode? list pattern"); } if (Tcl_ListObjGetElements (interp, objv [objc - 2], &listObjc, &listObjv) != TCL_OK) return TCL_ERROR; patternStr = Tcl_GetStringFromObj (objv [objc - 1], &patternLen); if ((mode != EXACT) && (strlen (patternStr) != (size_t) patternLen)) { goto binData; } for (idx = 0; idx < listObjc; idx++) { match = 0; valueStr = Tcl_GetStringFromObj (listObjv [idx], &valueLen); switch (mode) { case EXACT: match = (valueLen == patternLen) && (memcmp (valueStr, patternStr, valueLen) == 0); break; case GLOB: if (strlen (valueStr) != (size_t) valueLen) { goto binData; } match = Tcl_StringMatch (valueStr, patternStr); break; case REGEXP: if (strlen (valueStr) != (size_t) valueLen) { goto binData; } match = Tcl_RegExpMatch (interp, valueStr, patternStr); if (match < 0) { goto errorExit; } break; } if (match) { if (matchedListPtr == NULL) matchedListPtr = Tcl_NewListObj (0, NULL); if (Tcl_ListObjAppendElement (interp, matchedListPtr, listObjv [idx]) != TCL_OK) goto errorExit; } } if (matchedListPtr != NULL) { Tcl_SetObjResult (interp, matchedListPtr); } return TCL_OK; errorExit: if (matchedListPtr != NULL) Tcl_DecrRefCount (matchedListPtr); return TCL_ERROR; binData: TclX_AppendObjResult (interp, "The ", mode, " option does not support ", "binary data", (char *) NULL); return TCL_ERROR; } /*---------------------------------------------------------------------- * TclX_LcontainObjCmd -- * Implements the TclX lcontain command: * lcontain list element *---------------------------------------------------------------------- */ static int TclX_LcontainObjCmd (clientData, interp, objc, objv) ClientData clientData; Tcl_Interp *interp; int objc; Tcl_Obj *CONST objv[]; { int listObjc, idx; Tcl_Obj **listObjv; char *elementStr, *checkStr; int elementLen, checkLen; if (objc != 3) { return TclX_WrongArgs (interp, objv [0], "list element"); } if (Tcl_ListObjGetElements (interp, objv [1], &listObjc, &listObjv) != TCL_OK) return TCL_ERROR; checkStr = Tcl_GetStringFromObj (objv [2], &checkLen); for (idx = 0; idx < listObjc; idx++) { elementStr = Tcl_GetStringFromObj (listObjv [idx], &elementLen); if ((elementLen == checkLen) && (memcmp (elementStr, checkStr, elementLen) == 0)) break; } Tcl_SetBooleanObj (Tcl_GetObjResult (interp), (idx < listObjc)); return TCL_OK; } /*----------------------------------------------------------------------------- * TclX_ListInit -- * Initialize the list commands in an interpreter. * * Parameters: * o interp - Interpreter to add commands to. *----------------------------------------------------------------------------- */ void TclX_ListInit (interp) Tcl_Interp *interp; { Tcl_CreateObjCommand(interp, "lvarcat", TclX_LvarcatObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc*) NULL); Tcl_CreateObjCommand(interp, "lvarpop", TclX_LvarpopObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc*) NULL); Tcl_CreateObjCommand(interp, "lvarpush", TclX_LvarpushObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc*) NULL); Tcl_CreateObjCommand(interp, "lempty", TclX_LemptyObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc*) NULL); Tcl_CreateObjCommand(interp, "lassign", TclX_LassignObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc*) NULL); Tcl_CreateObjCommand(interp, "lmatch", TclX_LmatchObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc*) NULL); Tcl_CreateObjCommand(interp, "lcontain", TclX_LcontainObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc*) NULL); } tclx8.4-8.4.1.orig/generic/tclXutil.c0000644000000000000000000007634212046313170014156 0ustar /* * tclXutil.c * * Utility functions for Extended Tcl. *----------------------------------------------------------------------------- * Copyright 1991-1999 Karl Lehenbauer and Mark Diekhans. * * Permission to use, copy, modify, and distribute this software and its * documentation for any purpose and without fee is hereby granted, provided * that the above copyright notice appear in all copies. Karl Lehenbauer and * Mark Diekhans make no representations about the suitability of this * software for any purpose. It is provided "as is" without express or * implied warranty. *----------------------------------------------------------------------------- * $Id: tclXutil.c,v 1.3 2002/09/26 00:19:18 hobbs Exp $ *----------------------------------------------------------------------------- */ #include "tclExtdInt.h" #ifndef _tolower # define _tolower tolower # define _toupper toupper #endif /* * Prototypes of internal functions. */ static int ParseTranslationOption _ANSI_ARGS_((char *strValue)); static char * FormatTranslationOption _ANSI_ARGS_((int value)); static char *ERRORINFO = "errorInfo"; static char *ERRORCODE = "errorCode"; /* * Used to return argument messages by most commands. */ char *tclXWrongArgs = "wrong # args: "; /*----------------------------------------------------------------------------- * TclX_StrToInt -- * Convert an Ascii string to an number of the specified base. * * Parameters: * o string - String containing a number. * o base - The base to use for the number 8, 10 or 16 or zero to decide * based on the leading characters of the number. Zero to let the number * determine the base. * o intPtr - Place to return the converted number. Will be * unchanged if there is an error. * * Returns: * Returns 1 if the string was a valid number, 0 invalid. *----------------------------------------------------------------------------- */ int TclX_StrToInt (string, base, intPtr) CONST char *string; int base; int *intPtr; { char *end, *p; int i; /* * Note: use strtoul instead of strtol for integer conversions * to allow full-size unsigned numbers, but don't depend on strtoul * to handle sign characters; it won't in some implementations. */ errno = 0; for (p = (char *) string; isspace(UCHAR(*p)); p++) { /* Empty loop body. */ } if (*p == '-') { p++; i = -(int) strtoul(p, &end, base); } else if (*p == '+') { p++; i = strtoul(p, &end, base); } else { i = strtoul(p, &end, base); } if (end == p) { return FALSE; } if (errno == ERANGE) { return FALSE; } while ((*end != '\0') && isspace(UCHAR(*end))) { end++; } if (*end != '\0') { return FALSE; } *intPtr = i; return TRUE; } /*----------------------------------------------------------------------------- * TclX_StrToUnsigned -- * Convert an Ascii string to an unsigned int of the specified base. * * Parameters: * o string - String containing a number. * o base - The base to use for the number 8, 10 or 16 or zero to decide * based on the leading characters of the number. Zero to let the number * determine the base. * o unsignedPtr - Place to return the converted number. Will be * unchanged if there is an error. * * Returns: * Returns 1 if the string was a valid number, 0 invalid. *----------------------------------------------------------------------------- */ int TclX_StrToUnsigned (string, base, unsignedPtr) CONST char *string; int base; unsigned *unsignedPtr; { char *end, *p; unsigned i; errno = 0; for (p = (char *) string; isspace(UCHAR(*p)); p++) { /* Empty loop body. */ } i = strtoul(p, &end, base); if (end == p) { return FALSE; } if (errno == ERANGE) { return FALSE; } while ((*end != '\0') && isspace(UCHAR(*end))) { end++; } if (*end != '\0') { return FALSE; } *unsignedPtr = i; return TRUE; } /*----------------------------------------------------------------------------- * TclX_StrToOffset -- * Convert an Ascii string to an off_t number of the specified base. * * Parameters: * o string - String containing a number. * o base - The base to use for the number 8, 10 or 16 or zero to decide * based on the leading characters of the number. Zero to let the number * determine the base. * o offsetPtr - Place to return the converted number. Will be * unchanged if there is an error. * * Returns: * Returns 1 if the string was a valid number, 0 invalid. *----------------------------------------------------------------------------- */ int TclX_StrToOffset (string, base, offsetPtr) CONST char *string; int base; off_t *offsetPtr; { char *end, *p; off_t i; /* * Note: use strtoul instead of strtol for integer conversions * to allow full-size unsigned numbers, but don't depend on strtoul * to handle sign characters; it won't in some implementations. */ errno = 0; for (p = (char *) string; isspace(UCHAR(*p)); p++) { /* Empty loop body. */ } if (*p == '-') { p++; i = -(off_t) strtoul(p, &end, base); } else if (*p == '+') { p++; i = strtoul(p, &end, base); } else { i = strtoul(p, &end, base); } if (end == p) { return FALSE; } if (errno == ERANGE) { return FALSE; } while ((*end != '\0') && isspace(UCHAR(*end))) { end++; } if (*end != '\0') { return FALSE; } *offsetPtr = i; return TRUE; } /*----------------------------------------------------------------------------- * TclX_DownShift -- * Utility procedure to down-shift a string. It is written in such * a way as that the target string maybe the same as the source string. * * Parameters: * o targetStr - String to store the down-shifted string in. Must * have enough space allocated to store the string. If NULL is specified, * then the string will be dynamicly allocated and returned as the * result of the function. May also be the same as the source string to * shift in place. * o sourceStr - The string to down-shift. * * Returns: * A pointer to the down-shifted string * FIX: Make object based interface. *----------------------------------------------------------------------------- */ char * TclX_DownShift (targetStr, sourceStr) char *targetStr; CONST char *sourceStr; { register char theChar; if (targetStr == NULL) targetStr = ckalloc (strlen ((char *) sourceStr) + 1); for (; (theChar = *sourceStr) != '\0'; sourceStr++) { if (isupper (theChar)) theChar = _tolower (theChar); *targetStr++ = theChar; } *targetStr = '\0'; return targetStr; } /*----------------------------------------------------------------------------- * TclX_UpShift -- * Utility procedure to up-shift a string. * * Parameters: * o targetStr - String to store the up-shifted string in. Must * have enough space allocated to store the string. If NULL is specified, * then the string will be dynamicly allocated and returned as the * result of the function. May also be the same as the source string to * shift in place. * o sourceStr - The string to up-shift. * * Returns: * A pointer to the up-shifted string. * FIX: Get strcasecmp and replace this with it. * FIX: Make object based interface *----------------------------------------------------------------------------- */ char * TclX_UpShift (targetStr, sourceStr) char *targetStr; CONST char *sourceStr; { register char theChar; if (targetStr == NULL) targetStr = ckalloc (strlen ((char *) sourceStr) + 1); for (; (theChar = *sourceStr) != '\0'; sourceStr++) { if (ISLOWER (theChar)) theChar = _toupper (theChar); *targetStr++ = theChar; } *targetStr = '\0'; return targetStr; } /*----------------------------------------------------------------------------- * TclX_GetOffsetFromObj -- * Get the value of an integer objects as an unsigned. *----------------------------------------------------------------------------- */ int TclX_GetUnsignedFromObj (interp, objPtr, valuePtr) Tcl_Interp *interp; Tcl_Obj *objPtr; unsigned *valuePtr; { int intValue; if (Tcl_GetIntFromObj (interp, objPtr, &intValue) != TCL_OK) return TCL_ERROR; if (intValue < 0) { TclX_AppendObjResult (interp, "expected unsigned integer, got \"", Tcl_GetStringFromObj (objPtr, NULL), "\"", (char *) NULL); return TCL_ERROR; } *valuePtr = intValue; return TCL_OK; } /*----------------------------------------------------------------------------- * TclX_GetOffsetFromObj -- * Get the value of an integer objects as an off_t. *----------------------------------------------------------------------------- */ int TclX_GetOffsetFromObj (interp, objPtr, offsetPtr) Tcl_Interp *interp; Tcl_Obj *objPtr; off_t *offsetPtr; { int intOff; if (Tcl_GetIntFromObj (interp, objPtr, &intOff) != TCL_OK) return TCL_ERROR; *offsetPtr = intOff; return TCL_OK; } /*----------------------------------------------------------------------------- * TclX_RelativeExpr -- * * Evaluate an expression that may start with the magic words "end" or * "len". These strings are replaced with either the end offset or the * length that is passed in. * * Parameters: * o interp - A pointer to the interpreter. * o exprPtr - Object with expression to evaluate. * o stringLen - The length of the string or list. * o exprResultPtr - The result of the expression is returned here. * Returns: * TCL_OK or TCL_ERROR. *----------------------------------------------------------------------------- */ int TclX_RelativeExpr (interp, exprPtr, stringLen, exprResultPtr) Tcl_Interp *interp; Tcl_Obj *exprPtr; int stringLen; int *exprResultPtr; { char *exprStr, *buf; int exprLen, exprStrLen, result; long longResult; char staticBuf [32]; if (exprPtr->typePtr == Tcl_GetObjType ("int")) { if (Tcl_GetIntFromObj (interp, exprPtr, exprResultPtr) != TCL_OK) return TCL_ERROR; return TCL_OK; } exprStr = Tcl_GetStringFromObj (exprPtr, &exprStrLen); if (!(STRNEQU (exprStr, "end", 3) || STRNEQU (exprStr, "len", 3))) { if (Tcl_ExprLong (interp, exprStr, &longResult) != TCL_OK) { return TCL_ERROR; } *exprResultPtr = longResult; return TCL_OK; } sprintf (staticBuf, "%d", stringLen - ((exprStr [0] == 'e') ? 1 : 0)); exprLen = strlen (staticBuf) + exprStrLen - 2; buf = staticBuf; if (exprLen > sizeof (staticBuf)) { buf = (char *) ckalloc (exprLen); strcpy (buf, staticBuf); } strcat (buf, exprStr + 3); result = Tcl_ExprLong (interp, buf, &longResult); if (buf != staticBuf) ckfree (buf); if (result == TCL_OK) *exprResultPtr = longResult; return result; } /*----------------------------------------------------------------------------- * TclX_GetOpenChannel -- * * Convert a file handle to a channel with error checking. * * Parameters: * o interp - Current interpreter. * o handle - The file handle to convert. * o chanAccess - TCL_READABLE and/or TCL_WRITABLE, both or zero for no * checking. * Returns: * A the channel or NULL if an error occured. *----------------------------------------------------------------------------- */ Tcl_Channel TclX_GetOpenChannel (interp, handle, chanAccess) Tcl_Interp *interp; char *handle; int chanAccess; { Tcl_Channel chan; int mode; /*FIX: Delete when all converted to GetOpenChanelObj */ chan = Tcl_GetChannel (interp, handle, &mode); if (chan == (Tcl_Channel) NULL) { return NULL; } if ((chanAccess & TCL_READABLE) && ((mode & TCL_READABLE) == 0)) { TclX_AppendObjResult(interp, "channel \"", handle, "\" wasn't opened for reading", (char *) NULL); return NULL; } if ((chanAccess & TCL_WRITABLE) && ((mode & TCL_WRITABLE) == 0)) { TclX_AppendObjResult(interp, "channel \"", handle, "\" wasn't opened for writing", (char *) NULL); return NULL; } return chan; } /*----------------------------------------------------------------------------- * TclX_GetOpenChannelObj -- * * Convert a file handle to a channel with error checking. * * Parameters: * o interp - Current interpreter. * o handleObj - The file handle object to convert. * o chanAccess - TCL_READABLE and/or TCL_WRITABLE, both or zero for no * checking. * Returns: * A the channel or NULL if an error occured. *----------------------------------------------------------------------------- */ Tcl_Channel TclX_GetOpenChannelObj (interp, handleObj, chanAccess) Tcl_Interp *interp; Tcl_Obj *handleObj; int chanAccess; { Tcl_Channel chan; int mode; char *handle; handle = Tcl_GetStringFromObj (handleObj, NULL); chan = Tcl_GetChannel (interp, handle, &mode); if (chan == (Tcl_Channel) NULL) { return NULL; } if ((chanAccess & TCL_READABLE) && ((mode & TCL_READABLE) == 0)) { TclX_AppendObjResult (interp, "channel \"", handle, "\" wasn't opened for reading", (char *) NULL); return NULL; } if ((chanAccess & TCL_WRITABLE) && ((mode & TCL_WRITABLE) == 0)) { TclX_AppendObjResult (interp, "channel \"", handle, "\" wasn't opened for writing", (char *) NULL); return NULL; } return chan; } /*----------------------------------------------------------------------------- * ParseTranslationOption -- * * Parse the string that represents the translation value for one channel * direction. * * Parameters: * o strValue - Channel translation value. * Returns: * The integer option value. *----------------------------------------------------------------------------- */ static int ParseTranslationOption (strValue) char *strValue; { if (STREQU (strValue, "auto")) { return TCLX_TRANSLATE_AUTO; } else if (STREQU (strValue, "lf")) { return TCLX_TRANSLATE_LF; } else if (STREQU (strValue, "binary")) { return TCLX_TRANSLATE_BINARY; } else if (STREQU (strValue, "cr")) { return TCLX_TRANSLATE_CR; } else if (STREQU (strValue, "crlf")) { return TCLX_TRANSLATE_CRLF; } else if (STREQU (strValue, "platform")) { return TCLX_TRANSLATE_PLATFORM; } panic ("ParseTranslationOption bug"); return TCL_ERROR; /* Not reached */ } /*----------------------------------------------------------------------------- * FormatTranslationOption -- * * Format the string that represents the translation value for one channel * direction. * * Parameters: * o value - Integer channel translation value. * Returns: * The string option value. *---------------------------------------------------------------------------- */ static char * FormatTranslationOption (value) int value; { switch (value) { case TCLX_TRANSLATE_AUTO: return "auto"; case TCLX_TRANSLATE_LF: /* Also binary */ return "lf"; case TCLX_TRANSLATE_CR: return "cr"; case TCLX_TRANSLATE_CRLF: return "crlf"; case TCLX_TRANSLATE_PLATFORM: return "platform"; default: panic ("FormatTranslationOption bug"); } return NULL; /* Not reached */ } /*----------------------------------------------------------------------------- * TclX_GetChannelOption -- * * C-friendly front end to Tcl_GetChannelOption. * * Parameters: * o interp - Error message are returned in result * o channel - Channel to get the option for. * o optionName - One of the TCLX_COPT_* defines. * o valuePtr - Value is returned here. * Returns: * TCL_OK or TCL_ERROR. * FIX: Maybe drop these. *----------------------------------------------------------------------------- */ int TclX_GetChannelOption (interp, channel, option, valuePtr) Tcl_Interp *interp; Tcl_Channel channel; int option; int *valuePtr; { char *strOption; Tcl_DString strValue; int value = 0; Tcl_DStringInit (&strValue); switch (option) { case TCLX_COPT_BLOCKING: strOption = "-blocking"; break; case TCLX_COPT_BUFFERING: strOption = "-buffering"; break; case TCLX_COPT_TRANSLATION: strOption = "-translation"; break; default: goto fatalError; } if (Tcl_GetChannelOption (interp, channel, strOption, &strValue) != TCL_OK) { Tcl_DStringFree (&strValue); return TCL_ERROR; } switch (option) { case TCLX_COPT_BLOCKING: if (strValue.string [0] == '0') { value = TCLX_MODE_NONBLOCKING; } else { value = TCLX_MODE_BLOCKING; } break; case TCLX_COPT_BUFFERING: if (STREQU (strValue.string, "full")) { value = TCLX_BUFFERING_FULL; } else if (STREQU (strValue.string, "line")) { value = TCLX_BUFFERING_LINE; } else if (STREQU (strValue.string, "none")) { value = TCLX_BUFFERING_NONE; } else { goto fatalError; } break; case TCLX_COPT_TRANSLATION: { /* * The value returned is strange. Its either a single word, or * a list with a word for each file in the channel. However, in * Tcl 7.5, its actually retuned a list of a list, which is a bug. * Handle this and code for working with a fixed version. Hack * the list rather than doing, since we know the possible values * and this is much faster and easy to support both formats. * FIX: ???Clean up once Tcl fixes the return.??? */ char *strValue1, *strValue2, *strScan; strValue1 = strValue.string; if (strValue1 [0] == '{') strValue1++; /* Skip { if list of list */ strValue2 = strchr (strValue1, ' '); if (strValue2 != NULL) { strValue2 [0] = '\0'; /* Split into two strings. */ strValue2++; strScan = strchr (strValue2, '}'); if (strScan != NULL) *strScan = '\0'; } else { strValue2 = strValue1; } value = (ParseTranslationOption (strValue1) << TCLX_TRANSLATE_READ_SHIFT) | ParseTranslationOption (strValue2); break; } } Tcl_DStringFree (&strValue); *valuePtr = value; return TCL_OK; fatalError: panic ("TclX_GetChannelOption bug"); /* FIX: return error. */ return 0; /* Not reached */ } /*----------------------------------------------------------------------------- * TclX_SetChannelOption -- * * C-friendly front end to Tcl_SetChannelOption. * * Parameters: * o interp - Errors returned in result. * o channel - Channel to set the option for. * o option - One of the TCLX_COPT_* defines. * o value - Value to set the option to (integer define). Note, if * this is translation, it can either be the read and write directions * masked together or a single value. * Result: * TCL_OK or TCL_ERROR; *----------------------------------------------------------------------------- */ int TclX_SetChannelOption (interp, channel, option, value) Tcl_Interp *interp; Tcl_Channel channel; int option; int value; { char *strOption, *strValue; int readValue, writeValue; char valueList [64]; switch (option) { case TCLX_COPT_BLOCKING: strOption = "-blocking"; switch (value) { case TCLX_MODE_BLOCKING: strValue = "1"; break; case TCLX_MODE_NONBLOCKING: strValue = "0"; break; default: goto fatalError; } break; case TCLX_COPT_BUFFERING: strOption = "-buffering"; switch (value) { case TCLX_BUFFERING_FULL: strValue = "full"; break; case TCLX_BUFFERING_LINE: strValue = "line"; break; case TCLX_BUFFERING_NONE: strValue = "none"; break; default: goto fatalError; } break; case TCLX_COPT_TRANSLATION: /* * Hack a list together rather than allocate memory. If values for * read or write were not specified, specify both the same. */ readValue = (value & TCLX_TRANSLATE_READ_MASK) >> TCLX_TRANSLATE_READ_SHIFT; writeValue = (value & TCLX_TRANSLATE_WRITE_MASK); if (readValue == TCLX_TRANSLATE_UNSPECIFIED) readValue = writeValue; if (writeValue == TCLX_TRANSLATE_UNSPECIFIED) writeValue = readValue; strOption = "-translation"; valueList [0] = '\0'; valueList [sizeof (valueList) - 1] = '\0'; /* Overflow check */ strValue = valueList; strcat (valueList, FormatTranslationOption (readValue)); strcat (valueList, " "); strcat (valueList, FormatTranslationOption (writeValue)); if (valueList [sizeof (valueList) - 1] != '\0') goto fatalError; break; default: goto fatalError; } return Tcl_SetChannelOption (interp, channel, strOption, strValue); fatalError: panic ("TclX_SetChannelOption bug"); return TCL_ERROR; /* Not reached */ } /*----------------------------------------------------------------------------- * TclX_JoinPath -- * * Interface to Tcl_Join path to join only two files. * * Parameters: * o path1, path2 - File paths to join. * o joinedPath - DString buffere that joined path is returned in. * must be initialized. * Returns: * A pointer to joinedPath->string. *----------------------------------------------------------------------------- */ char * TclX_JoinPath (path1, path2, joinedPath) char *path1; char *path2; Tcl_DString *joinedPath; { CONST84 char *joinArgv [2]; joinArgv [0] = path1; joinArgv [1] = path2; Tcl_JoinPath (2, joinArgv, joinedPath); return joinedPath->string; } /*----------------------------------------------------------------------------- * TclX_WrongArgs -- * * Easily create "wrong # args" error messages. * * Parameters: * o commandNameObj - Object containing name of command (objv[0]) * o string - Text message to append. * Returns: * TCL_ERROR *----------------------------------------------------------------------------- */ int TclX_WrongArgs (interp, commandNameObj, string) Tcl_Interp *interp; Tcl_Obj *commandNameObj; char *string; { char *commandName; Tcl_Obj *resultPtr = Tcl_GetObjResult (interp); int commandLength; commandName = Tcl_GetStringFromObj (commandNameObj, &commandLength); Tcl_AppendStringsToObj (resultPtr, tclXWrongArgs, commandName, (char *)NULL); if (*string != '\0') { Tcl_AppendStringsToObj (resultPtr, " ", string, (char *)NULL); } return TCL_ERROR; } /*----------------------------------------------------------------------------- * TclX_AppendObjResult -- * * Append a variable number of strings onto the object result already * present for an interpreter. If the object is shared, the current contents * are discarded. * * Parameters: * o interp - Interpreter to set the result in. * o args - Strings to append, terminated by a NULL. *----------------------------------------------------------------------------- */ void TclX_AppendObjResult TCL_VARARGS_DEF (Tcl_Interp *, arg1) { Tcl_Interp *interp; Tcl_Obj *resultPtr; va_list argList; char *string; interp = TCL_VARARGS_START (Tcl_Interp *, arg1, argList); resultPtr = Tcl_GetObjResult (interp); if (Tcl_IsShared(resultPtr)) { resultPtr = Tcl_NewStringObj((char *)NULL, 0); Tcl_SetObjResult(interp, resultPtr); } TCL_VARARGS_START(Tcl_Interp *,arg1,argList); while (1) { string = va_arg(argList, char *); if (string == NULL) { break; } Tcl_AppendToObj (resultPtr, string, -1); } va_end(argList); } /*----------------------------------------------------------------------------- * TclX_IsNullObj -- * * Check if an object is {}, either in list or zero-lemngth string form, with * out forcing a conversion. * * Parameters: * o objPtr - Object to check. * Returns: * True if NULL, FALSE if not. *----------------------------------------------------------------------------- */ int TclX_IsNullObj (objPtr) Tcl_Obj *objPtr; { static Tcl_ObjType *listType = NULL, *stringType = NULL; int length; /* * Only get types once, as they must be static. */ if (listType == NULL) { listType = Tcl_GetObjType ("list"); stringType = Tcl_GetObjType ("string"); } if (objPtr->typePtr == NULL) { return (objPtr->length == 0); } else { if (objPtr->typePtr == listType) { Tcl_ListObjLength (NULL, objPtr, &length); return (length == 0); } else if (objPtr->typePtr == stringType) { Tcl_GetStringFromObj (objPtr, &length); return (length == 0); } } Tcl_GetStringFromObj (objPtr, &length); return (length == 0); } /*----------------------------------------------------------------------------- * TclX_SaveResultErrorInfo -- * * Saves the Tcl interp result plus errorInfo and errorCode in a structure. * * Parameters: * o interp - Interpreter to save state for. * Returns: * A list object containing the state. *----------------------------------------------------------------------------- */ Tcl_Obj * TclX_SaveResultErrorInfo (interp) Tcl_Interp *interp; { Tcl_Obj *saveObjv [4]; Tcl_Obj *listObj; long flags = ((Interp *)interp)->flags & (ERR_ALREADY_LOGGED | ERR_IN_PROGRESS | ERROR_CODE_SET); saveObjv [0] = Tcl_DuplicateObj (Tcl_GetObjResult (interp)); saveObjv [1] = Tcl_GetVar2Ex(interp, ERRORINFO, NULL, TCL_GLOBAL_ONLY); if (saveObjv [1] == NULL) { saveObjv [1] = Tcl_NewObj (); } saveObjv [2] = Tcl_GetVar2Ex(interp, ERRORCODE, NULL, TCL_GLOBAL_ONLY); if (saveObjv [2] == NULL) { saveObjv [2] = Tcl_NewObj (); } saveObjv [3] = Tcl_NewLongObj(flags); Tcl_IncrRefCount(listObj = Tcl_NewListObj (4, saveObjv)); return listObj; } /*----------------------------------------------------------------------------- * TclX_RestoreResultErrorInfo -- * * Restores the Tcl interp state from TclX_SaveResultErrorInfo. * * Parameters: * o interp - Interpreter to save state for. * o saveObjPtr - Object returned from TclX_SaveResultErrorInfo. Ref count * will be decremented. *----------------------------------------------------------------------------- */ void TclX_RestoreResultErrorInfo (interp, saveObjPtr) Tcl_Interp *interp; Tcl_Obj *saveObjPtr; { Tcl_Obj **saveObjv; int saveObjc; long flags; if ((Tcl_ListObjGetElements (NULL, saveObjPtr, &saveObjc, &saveObjv) != TCL_OK) || (saveObjc != 4) || (Tcl_GetLongFromObj (NULL, saveObjv[3], &flags) != TCL_OK)) { /* * This should never happen */ panic ("invalid TclX result save object"); } Tcl_SetVar2Ex(interp, ERRORCODE, NULL, saveObjv[2], TCL_GLOBAL_ONLY); Tcl_SetVar2Ex(interp, ERRORINFO, NULL, saveObjv[1], TCL_GLOBAL_ONLY); Tcl_SetObjResult (interp, saveObjv[0]); ((Interp *)interp)->flags |= flags; Tcl_DecrRefCount (saveObjPtr); } /*-------------------------------------------------------------------------- * TclX_CreateObjCommand -- * * Handles the creation of TclX commands. Used for commands who come * in conflict with other extensions. * * Parameters: * o Like Tcl_CreateObjCommand * o flags - Additional flags to control the behaviour of the procedure. *-------------------------------------------------------------------------- */ int TclX_CreateObjCommand (interp, cmdName, proc, clientData, deleteProc, flags) Tcl_Interp* interp; char* cmdName; Tcl_ObjCmdProc* proc; ClientData clientData; Tcl_CmdDeleteProc* deleteProc; int flags; { Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp); Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); Tcl_HashTable *gTblPtr, *cTblPtr; static size_t offset = TclX_Offset(Namespace, cmdTable); gTblPtr = (Tcl_HashTable *) TclX_StructOffset(globalNsPtr, offset, 0); cTblPtr = (Tcl_HashTable *) TclX_StructOffset(currNsPtr, offset, 0); if ((flags & TCLX_CMD_REDEFINE) || !(Tcl_FindHashEntry(gTblPtr, cmdName) || Tcl_FindHashEntry(cTblPtr, cmdName))) { Tcl_CreateObjCommand(interp, cmdName, proc, clientData, deleteProc); } if (!(cmdName[0] == 't' && cmdName[1] == 'c' && cmdName[2] == 'l' && cmdName[3] == 'x') && !(flags & TCLX_CMD_NOPREFIX)) { char cmdnamebuf[80]; sprintf(cmdnamebuf, "tclx_%s", cmdName); Tcl_CreateObjCommand(interp, cmdnamebuf, proc, clientData, deleteProc); } return TCL_OK; } /*-------------------------------------------------------------------------- * TclX_NSOffset -- * * Handles offsets into a private structure, which has changed in size from * 8.3 to 8.4. Currently only for Namespace, but others could be added. *-------------------------------------------------------------------------- */ void * TclX_StructOffset(nsPtr, offset, offType) void *nsPtr; size_t offset; unsigned int offType; { int major, minor, i; /* * These size_t pairs indicate the element at which we will have a * shift in size and the size by which it will shift. */ static size_t nsOffs[] = { TclX_Offset(Namespace, varTable), sizeof(void *), TclX_Offset(Namespace, cmdTable), sizeof(void *), TclX_Offset(Namespace, childTable), sizeof(void *), 0, 0 }; /* * Get the version so we can runtime switch on available functionality. * 8.0 is the lowest we compile with, so use that assumption. */ Tcl_GetVersion(&major, &minor, NULL, NULL); #if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION < 4 /* * Headers are <= 8.3 for offset calculations, so we only need to * adjust for 8.4+ interpreters. */ if ((major > 8) || (minor > 3)) { for (i = 0; nsOffs[i] != 0; i += 2) { if (offset > nsOffs[i]) { offset += nsOffs[i+1]; } } } #else /* * Headers are >= 8.4 for offset calculations, so we only need to * adjust for 8.3- interpreters. */ if ((major == 8) && (minor < 4)) { for (i = 0; nsOffs[i] != 0; i += 2) { if (offset > nsOffs[i]) { offset -= nsOffs[i+1]; } } } #endif return (void *)((size_t) nsPtr + offset); } tclx8.4-8.4.1.orig/generic/tclXcmdloop.c0000644000000000000000000006475712046313170014645 0ustar /* * tclXcmdloop -- * * Interactive command loop, C and Tcl callable. *----------------------------------------------------------------------------- * Copyright 1991-1999 Karl Lehenbauer and Mark Diekhans. * * Permission to use, copy, modify, and distribute this software and its * documentation for any purpose and without fee is hereby granted, provided * that the above copyright notice appear in all copies. Karl Lehenbauer and * Mark Diekhans make no representations about the suitability of this * software for any purpose. It is provided "as is" without express or * implied warranty. *----------------------------------------------------------------------------- * $Id: tclXcmdloop.c,v 1.3 2002/09/26 00:19:18 hobbs Exp $ *----------------------------------------------------------------------------- */ #include "tclExtdInt.h" /* * Client data entry for asynchronous command reading. This is associated * with a given instance of a async command loop. I allows for recursive * commands loops on the same channel (and even multiple, but the results * out be unpredicatable). */ typedef struct { Tcl_Interp *interp; /* Interp for command eval. */ Tcl_Channel channel; /* Input channel. */ int options; /* Command loop options. */ Tcl_DString command; /* Buffer for command being read. */ int partial; /* Partial command in buffer? */ char *endCommand; /* Command to execute at end of loop. */ char *prompt1; /* Prompts to use. */ char *prompt2; } asyncLoopData_t; /* * Prototypes of internal functions. */ static int IsSetVarCmd _ANSI_ARGS_((char *command)); static void OutputPrompt _ANSI_ARGS_((Tcl_Interp *interp, int topLevel, char *prompt1, char *prompt2)); static int AsyncSignalErrorHandler _ANSI_ARGS_((Tcl_Interp *interp, ClientData clientData, int background, int signalNum)); static void AsyncCommandHandler _ANSI_ARGS_((ClientData clientData, int mask)); static int SyncSignalErrorHandler _ANSI_ARGS_((Tcl_Interp *interp, ClientData clientData, int background, int signalNum)); static void AsyncCommandHandlerDelete _ANSI_ARGS_((ClientData clientData)); static int TclX_CommandloopObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); /*----------------------------------------------------------------------------- * IsSetVarCmd -- * Determine if a command is a `set' command that sets a variable * (i.e. two arguments). * * Parameters: * o command (I) - Command to check. * Returns: * TRUE if it is a set that sets a variable, FALSE if its some other command. *----------------------------------------------------------------------------- */ static int IsSetVarCmd (command) char *command; { Tcl_Parse tclParse; int numWords; if ((!STRNEQU (command, "set", 3)) || (!ISSPACE (command [3]))) return FALSE; /* Quick check */ Tcl_ParseCommand(NULL, command, -1, 1, &tclParse); numWords = tclParse.numWords; Tcl_FreeParse(&tclParse); return numWords > 2 ? TRUE : FALSE; } /*----------------------------------------------------------------------------- * TclX_PrintResult -- * Print the result of a Tcl_Eval. It can optionally not echo "set" commands * that successfully set a variable. * * Parameters: * o interp (I) - A pointer to the interpreter. Result of command should be * in interp result. * o intResult (I) - The integer result returned by Tcl_Eval. * o checkCmd (I) - If not NULL and the command was sucessful, check to * set if this is a "set" command setting a variable. If so, don't echo * the result. *----------------------------------------------------------------------------- */ void TclX_PrintResult (interp, intResult, checkCmd) Tcl_Interp *interp; int intResult; char *checkCmd; { Tcl_Channel stdoutChan, stderrChan; char *resultStr; /* * If the command was supplied and it was a successful set of a variable, * don't output the result. */ if ((checkCmd != NULL) && (intResult == TCL_OK) && IsSetVarCmd (checkCmd)) return; stdoutChan = Tcl_GetStdChannel(TCL_STDOUT); stderrChan = Tcl_GetStdChannel(TCL_STDERR); if (intResult == TCL_OK) { if (stdoutChan == NULL) return; resultStr = Tcl_GetStringFromObj(Tcl_GetObjResult(interp), NULL); if (resultStr [0] != '\0') { if (stderrChan != NULL) Tcl_Flush (stderrChan); Tcl_WriteChars(stdoutChan, resultStr, -1); TclX_WriteNL(stdoutChan); Tcl_Flush(stdoutChan); } } else { char msg [64]; if (stderrChan == NULL) return; if (stdoutChan != NULL) Tcl_Flush (stdoutChan); if (intResult == TCL_ERROR) { strcpy(msg, "Error: "); } else { sprintf(msg, "Bad return code (%d): ", intResult); } resultStr = Tcl_GetStringFromObj(Tcl_GetObjResult(interp), NULL); Tcl_WriteChars(stderrChan, msg, -1); Tcl_WriteChars(stderrChan, resultStr, -1); TclX_WriteNL(stderrChan); Tcl_Flush(stderrChan); } } /*----------------------------------------------------------------------------- * OutputPrompt -- * Outputs a prompt by executing either the command string in tcl_prompt1 or * tcl_prompt2 or a specified prompt string. Also involkes any pending async * handlers, as these need to be done before the eval of the prompt, or they * might result in an error in the prompt. * * Parameters: * o interp (I) - A pointer to the interpreter. * o topLevel (I) - If TRUE, output the top level prompt (tcl_prompt1). * o prompt1 (I) - If not NULL, use this command instead of the value of * tcl_prompt1. In this case, the result of the command is used rather * than the output. * o prompt2 (I) - If not NULL, use this command instead of the value of * tcl_prompt2. In this case, the result of the command is used rather * than the output. *----------------------------------------------------------------------------- */ static void OutputPrompt (interp, topLevel, prompt1, prompt2) Tcl_Interp *interp; int topLevel; char *prompt1; char *prompt2; { char *promptHook; char *resultStr; int result, useResult, promptDone = FALSE; Tcl_Channel stdoutChan, stderrChan; stdoutChan = Tcl_GetStdChannel (TCL_STDOUT); stderrChan = Tcl_GetStdChannel (TCL_STDERR); /* * If a signal came in, process it. This prevents signals that are queued * from generating prompt hook errors. */ if (Tcl_AsyncReady ()) { Tcl_AsyncInvoke (interp, TCL_OK); } if (stderrChan != NULL) Tcl_Flush (stderrChan); /* * Determine prompt command to evaluate. */ if (topLevel) { if (prompt1 != NULL) { promptHook = prompt1; useResult = TRUE; } else { promptHook = (char *) Tcl_GetVar (interp, "tcl_prompt1", TCL_GLOBAL_ONLY); useResult = FALSE; } } else { if (prompt2 != NULL) { promptHook = prompt2; useResult = TRUE; } else { promptHook = (char *) Tcl_GetVar (interp, "tcl_prompt2", TCL_GLOBAL_ONLY); useResult = FALSE; } } if (promptHook != NULL) { result = Tcl_Eval (interp, promptHook); resultStr = Tcl_GetStringFromObj (Tcl_GetObjResult (interp), NULL); if (result == TCL_ERROR) { if (stderrChan != NULL) { Tcl_WriteChars(stderrChan, "Error in prompt hook: ", -1); Tcl_WriteChars(stderrChan, resultStr, -1); TclX_WriteNL (stderrChan); } } else { if (useResult && (stdoutChan != NULL)) Tcl_WriteChars(stdoutChan, resultStr, -1); promptDone = TRUE; } } if (stdoutChan != NULL) { if (!promptDone) Tcl_Write (stdoutChan, topLevel ? "%" : ">", 1); Tcl_Flush (stdoutChan); } Tcl_ResetResult (interp); } /*----------------------------------------------------------------------------- * AsyncSignalErrorHandler -- * Handler for signals that generate errors. If no code is currently * executing (i.e, it the event loop), we want the input buffer to be * cleared on SIGINT. * * Parameters: * o interp (I) - The interpreter used to process the signal. The error * message is in the result. * o clientData (I) - Pointer to the asyncLoopData structure. * o background (I) - TRUE if signal was handled in the background (i.e * the event loop) rather than in an interp. * Returns: * The Tcl result code to continue with. TCL_OK if we have handled the * signal, TCL_ERROR if not. *----------------------------------------------------------------------------- */ static int AsyncSignalErrorHandler (interp, clientData, background, signalNum) Tcl_Interp *interp; ClientData clientData; int background; int signalNum; { if (background & (signalNum == SIGINT)) { asyncLoopData_t *dataPtr = (asyncLoopData_t *) clientData; Tcl_Channel stdoutChan = Tcl_GetStdChannel (TCL_STDOUT); Tcl_DStringFree (&dataPtr->command); dataPtr->partial = FALSE; Tcl_ResetResult (interp); if (dataPtr->options & TCLX_CMDL_INTERACTIVE) { if (stdoutChan != NULL) TclX_WriteNL (stdoutChan); OutputPrompt (dataPtr->interp, !dataPtr->partial, dataPtr->prompt1, dataPtr->prompt2); } return TCL_OK; } return TCL_ERROR; } /*----------------------------------------------------------------------------- * AsyncCommandHandler -- * Handler for async command reading. This procedure is invoked by the event * dispatcher whenever the input becomes readable. It grabs the next line of * input characters, adds them to a command being assembled, and executes the * command if it's complete. * * Parameters: * o clientData (I) - Pointer to the asyncLoopData structure. * o mask (I) - Not used. *----------------------------------------------------------------------------- */ static void AsyncCommandHandler (clientData, mask) ClientData clientData; int mask; { asyncLoopData_t *dataPtr = (asyncLoopData_t *) clientData; int code; char *cmd, *resultStr; /* * Make sure that we are the current signal error handler. This * handles recusive event loop calls. */ TclX_SetAppSignalErrorHandler (AsyncSignalErrorHandler, clientData); if (Tcl_Gets (dataPtr->channel, &dataPtr->command) < 0) { /* * Handler EINTR error special. */ if (!(Tcl_Eof (dataPtr->channel) || Tcl_InputBlocked (dataPtr->channel)) && (Tcl_GetErrno () == EINTR)) { if (Tcl_AsyncReady ()) { Tcl_AsyncInvoke (NULL, TCL_OK); } return; /* Let the event loop call us again. */ } /* * Handle EOF or error. */ if (dataPtr->options & TCLX_CMDL_EXIT_ON_EOF) { Tcl_Exit (0); } else { AsyncCommandHandlerDelete (clientData); } return; } cmd = Tcl_DStringAppend (&dataPtr->command, "\n", -1); if (!Tcl_CommandComplete (cmd)) { dataPtr->partial = TRUE; goto prompt; } dataPtr->partial = FALSE; /* * Disable the stdin channel handler while evaluating the command; * otherwise if the command re-enters the event loop we might process * commands from stdin before the current command is finished. Among * other things, this will trash the text of the command being evaluated. */ Tcl_CreateChannelHandler (dataPtr->channel, 0, AsyncCommandHandler, clientData); code = Tcl_RecordAndEval (dataPtr->interp, cmd, TCL_EVAL_GLOBAL); Tcl_CreateChannelHandler (dataPtr->channel, TCL_READABLE, AsyncCommandHandler, clientData); resultStr = Tcl_GetStringFromObj (Tcl_GetObjResult (dataPtr->interp), NULL); if (resultStr [0] != '\0') { if (dataPtr->options & TCLX_CMDL_INTERACTIVE) { TclX_PrintResult (dataPtr->interp, code, cmd); } } Tcl_DStringFree (&dataPtr->command); /* * Output a prompt. */ prompt: if (dataPtr->options & TCLX_CMDL_INTERACTIVE) { OutputPrompt (dataPtr->interp, !dataPtr->partial, dataPtr->prompt1, dataPtr->prompt2); } Tcl_ResetResult (dataPtr->interp); } /*----------------------------------------------------------------------------- * AsyncCommandHandlerDelete -- * Delete an async command handler. * * Parameters: * o clientData (I) - Pointer to the asyncLoopData structure for the * handler being deleted. *----------------------------------------------------------------------------- */ static void AsyncCommandHandlerDelete (clientData) ClientData clientData; { asyncLoopData_t *dataPtr = (asyncLoopData_t *) clientData; /* * Remove handlers from system. */ Tcl_DeleteChannelHandler (dataPtr->channel, AsyncCommandHandler, clientData); Tcl_DeleteCloseHandler (dataPtr->channel, AsyncCommandHandlerDelete, clientData); TclX_SetAppSignalErrorHandler (NULL, NULL); /* * If there is an end command, eval it. */ if (dataPtr->endCommand != NULL) { if (Tcl_GlobalEval (dataPtr->interp, dataPtr->endCommand) != TCL_OK) Tcl_BackgroundError (dataPtr->interp); Tcl_ResetResult (dataPtr->interp); } /* * Free resources. */ Tcl_DStringFree (&dataPtr->command); if (dataPtr->endCommand != NULL) ckfree (dataPtr->endCommand); if (dataPtr->prompt1 != NULL) ckfree (dataPtr->prompt1); if (dataPtr->prompt2 != NULL) ckfree (dataPtr->prompt2); ckfree ((char *) dataPtr); } /*----------------------------------------------------------------------------- * TclX_AsyncCommandLoop -- * Establish an async command handler on stdin. * * Parameters: * o interp (I) - A pointer to the interpreter * o options (I) - Async command loop options: * o TCLX_CMDL_INTERACTIVE - Print a prompt and the result of command * execution. * o TCLX_CMDL_EXIT_ON_EOF - Exit when an EOF is encountered. * o endCommand (I) - If not NULL, a command to evaluate when the command * handler is removed, either by closing the channel or hitting EOF. * o prompt1 (I) - If not NULL, the command to evalute get the main prompt. * If NULL, the current value of tcl_prompt1 is evaluted to output the * main prompt. NOTE: prompt1 returns a result while tcl_prompt1 * outputs a result. * o prompt2 (I) - If not NULL, the command to evalute get the secondary * prompt. If NULL, the current value of tcl_prompt is evaluted to * output the secondary prompt. NOTE: prompt2 returns a result while * tcl_prompt2 outputs a result. * Returns: * TCL_OK or TCL_ERROR; *----------------------------------------------------------------------------- */ int TclX_AsyncCommandLoop (interp, options, endCommand, prompt1, prompt2) Tcl_Interp *interp; int options; char *endCommand; char *prompt1; char *prompt2; { Tcl_Channel stdinChan; asyncLoopData_t *dataPtr; stdinChan = TclX_GetOpenChannel (interp, "stdin", TCL_READABLE); if (stdinChan == NULL) return TCL_ERROR; dataPtr = (asyncLoopData_t *) ckalloc (sizeof (asyncLoopData_t)); dataPtr->interp = interp; dataPtr->channel = stdinChan; dataPtr->options = options; Tcl_DStringInit (&dataPtr->command); dataPtr->partial = FALSE; if (endCommand == NULL) dataPtr->endCommand = NULL; else dataPtr->endCommand = ckstrdup (endCommand); if (prompt1 == NULL) dataPtr->prompt1 = NULL; else dataPtr->prompt1 = ckstrdup (prompt1); if (prompt2 == NULL) dataPtr->prompt2 = NULL; else dataPtr->prompt2 = ckstrdup (prompt2); Tcl_DeleteCloseHandler (stdinChan, AsyncCommandHandlerDelete, (ClientData) dataPtr); Tcl_CreateChannelHandler (stdinChan, TCL_READABLE, AsyncCommandHandler, (ClientData) dataPtr); TclX_SetAppSignalErrorHandler (AsyncSignalErrorHandler, (ClientData) dataPtr); /* * Output initial prompt. */ if (dataPtr->options & TCLX_CMDL_INTERACTIVE) { OutputPrompt (dataPtr->interp, !dataPtr->partial, dataPtr->prompt1, dataPtr->prompt2); } return TCL_OK; } /*----------------------------------------------------------------------------- * SyncSignalErrorHandler -- * Handler for signals that generate errors. We want to clear the input * buffer on SIGINT. * * Parameters: * o interp (I) - The interpreter used to process the signal. The error * message is in the result. * o clientData (I) - Pointer to a int to set to TRUE if SIGINT occurs. * o background (I) - Ignored. * Returns: * The Tcl result code to continue with. TCL_OK if we have handled the * signal, TCL_ERROR if not. *----------------------------------------------------------------------------- */ static int SyncSignalErrorHandler (interp, clientData, background, signalNum) Tcl_Interp *interp; ClientData clientData; int background; int signalNum; { if (signalNum == SIGINT) { *((int *) clientData) = TRUE; } return TCL_ERROR; } /*----------------------------------------------------------------------------- * TclX_CommandLoop -- * Run a syncronous Tcl command loop. EOF terminates the loop. * * Parameters: * o interp (I) - A pointer to the interpreter * o options (I) - Command loop options: * o TCLX_CMDL_INTERACTIVE - Print a prompt and the result of command * execution. * o prompt1 (I) - If not NULL, the command to evalute get the main prompt. * If NULL, the current value of tcl_prompt1 is evaluted to output the * main prompt. NOTE: prompt1 returns a result while tcl_prompt1 * outputs a result. * o prompt2 (I) - If not NULL, the command to evalute get the secondary * prompt. If NULL, the current value of tcl_prompt is evaluted to * output the secondary prompt. NOTE: prompt2 returns a result while * tcl_prompt2 outputs a result. * Returns: * TCL_OK or TCL_ERROR; *----------------------------------------------------------------------------- */ int TclX_CommandLoop (interp, options, endCommand, prompt1, prompt2) Tcl_Interp *interp; int options; char *endCommand; char *prompt1; char *prompt2; { Tcl_DString command; int result, partial = FALSE, gotSigIntError = FALSE, gotInterrupted = FALSE; Tcl_Channel stdinChan, stdoutChan; Tcl_DStringInit (&command); while (TRUE) { /* * Always set signal error handler so recursive command loops work. */ TclX_SetAppSignalErrorHandler (SyncSignalErrorHandler, &gotSigIntError); /* * If a signal handlers are pending, process them. */ if (Tcl_AsyncReady ()) { result = Tcl_AsyncInvoke (interp, TCL_OK); if ((result != TCL_OK) && !gotSigIntError) TclX_PrintResult (interp, result, NULL); } /* * Drop any pending command if SIGINT occured since the last time we * were through here, event if its already been processed. */ if (gotSigIntError) { Tcl_DStringFree (&command); partial = FALSE; stdoutChan = Tcl_GetStdChannel (TCL_STDOUT); if (stdoutChan != NULL) TclX_WriteNL (stdoutChan); } /* * Output a prompt and input a command. */ stdinChan = Tcl_GetStdChannel (TCL_STDIN); if (stdinChan == NULL) goto endOfFile; /* * Only ouput prompt if we didn't get interrupted or if the * interruption was SIGINT */ if ((options & TCLX_CMDL_INTERACTIVE) && (!gotInterrupted || gotSigIntError)) { OutputPrompt (interp, !partial, prompt1, prompt2); } /* * Reset these flags for the next round */ gotSigIntError = FALSE; gotInterrupted = FALSE; result = Tcl_Gets (stdinChan, &command); if (result < 0) { if (Tcl_Eof (stdinChan) || Tcl_InputBlocked (stdinChan)) goto endOfFile; if (Tcl_GetErrno () == EINTR) { gotInterrupted = TRUE; continue; /* Process signals above */ } TclX_AppendObjResult (interp, "command input error on stdin: ", Tcl_PosixError (interp), (char *) NULL); return TCL_ERROR; } /* * Newline was stripped by Tcl_DStringGets, but is needed for * command-complete checking, add it back in. If the command is * not complete, get the next line. */ Tcl_DStringAppend (&command, "\n", 1); if (!Tcl_CommandComplete (command.string)) { partial = TRUE; continue; /* Next line */ } /* * Finally have a complete command, go eval it and maybe output the * result. */ result = Tcl_RecordAndEval (interp, command.string, 0); if ((options & TCLX_CMDL_INTERACTIVE) || (result != TCL_OK)) TclX_PrintResult (interp, result, command.string); partial = FALSE; Tcl_DStringFree (&command); } endOfFile: Tcl_DStringFree (&command); if (endCommand != NULL) { if (Tcl_Eval (interp, endCommand) == TCL_ERROR) { return TCL_ERROR; } } return TCL_OK; } /*----------------------------------------------------------------------------- * Tcl_CommandloopObjCmd -- * Implements the commandloop command: * commandloop -async -interactive on|off|tty -prompt1 cmd * -prompt2 cmd -endcommand cmd * Results: * Standard TCL results. *----------------------------------------------------------------------------- */ static int TclX_CommandloopObjCmd (clientData, interp, objc, objv) ClientData clientData; Tcl_Interp *interp; int objc; Tcl_Obj *CONST objv[]; { int options = 0, async = FALSE, argIdx, interactive; char *argStr, *endCommand = NULL; char *prompt1 = NULL, *prompt2 = NULL; interactive = isatty (0); for (argIdx = 1; argIdx < objc; argIdx++) { argStr = Tcl_GetStringFromObj (objv [argIdx], NULL); if (argStr [0] != '-') break; if (STREQU (argStr, "-async")) { async = TRUE; } else if (STREQU (argStr, "-prompt1")) { if (argIdx == objc - 1) goto argRequired; prompt1 = Tcl_GetStringFromObj (objv [++argIdx], NULL);; } else if (STREQU (argStr, "-prompt2")) { if (argIdx == objc - 1) goto argRequired; prompt2 = Tcl_GetStringFromObj (objv [++argIdx], NULL); } else if (STREQU (argStr, "-interactive")) { if (argIdx == objc - 1) goto argRequired; argIdx++; argStr = Tcl_GetStringFromObj (objv [argIdx], NULL); if (STREQU (argStr, "tty")) { interactive = TRUE; } else { if (Tcl_GetBooleanFromObj (interp, objv [argIdx], &interactive) != TCL_OK) return TCL_ERROR; } } else if (STREQU (argStr, "-endcommand")) { if (argIdx == objc - 1) goto argRequired; endCommand = Tcl_GetStringFromObj (objv [++argIdx], NULL); } else { goto unknownOption; } } if (argIdx != objc) goto wrongArgs; if (interactive) options |= TCLX_CMDL_INTERACTIVE; if (async) { return TclX_AsyncCommandLoop (interp, options, endCommand, prompt1, prompt2); } else { return TclX_CommandLoop (interp, options, endCommand, prompt1, prompt2); } /* * Argument error message generation. argStr should contain the * option being processed. */ argRequired: TclX_AppendObjResult (interp, "argument required for ", argStr, " option", (char *) NULL); return TCL_ERROR; unknownOption: TclX_AppendObjResult (interp, "unknown option \"", argStr, "\", expected one of \"-async\", ", "\"-interactive\", \"-prompt1\", \"-prompt2\", ", " or \"-endcommand\"", (char *) NULL); return TCL_ERROR; wrongArgs: TclX_WrongArgs (interp, objv [0], "?-async? ?-interactive on|off|tty? ?-prompt1 cmd? ?-prompt2 cmd? ?-endcommand cmd?"); return TCL_ERROR; } /*----------------------------------------------------------------------------- * TclX_CmdloopInit -- * Initialize the coommandloop command. *----------------------------------------------------------------------------- */ void TclX_CmdloopInit (interp) Tcl_Interp *interp; { Tcl_CreateObjCommand (interp, "commandloop", TclX_CommandloopObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc*) NULL); } tclx8.4-8.4.1.orig/generic/tclXstring.c0000644000000000000000000007337012046313170014505 0ustar /* * tclXstring.c -- * * Extended TCL string and character manipulation commands. *----------------------------------------------------------------------------- * Copyright 1991-1999 Karl Lehenbauer and Mark Diekhans. * * Permission to use, copy, modify, and distribute this software and its * documentation for any purpose and without fee is hereby granted, provided * that the above copyright notice appear in all copies. Karl Lehenbauer and * Mark Diekhans make no representations about the suitability of this * software for any purpose. It is provided "as is" without express or * implied warranty. *----------------------------------------------------------------------------- * $Id: tclXstring.c,v 1.4 2005/11/21 18:38:51 hobbs Exp $ *----------------------------------------------------------------------------- */ /*FIX: Add creplace to overwrite characters in a string. */ #include "tclExtdInt.h" /* * Prototypes of internal functions. */ static int CheckForUniCode _ANSI_ARGS_((Tcl_Interp *interp, char *str, int strLen, char *which)); static unsigned int ExpandString _ANSI_ARGS_((unsigned char *inStr, int inLength, unsigned char outStr [], int *outLengthPtr)); static int TclX_CindexObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int TclX_ClengthObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int TclX_CconcatObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int TclX_CrangeObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int TclX_CcollateObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int TclX_ReplicateObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int TclX_TranslitObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int TclX_CtypeObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int TclX_CtokenObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int TclX_CequalObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); /*----------------------------------------------------------------------------- * TclX_CindexObjCmd -- * Implements the cindex Tcl command: * cindex string indexExpr * * Results: * Returns the character indexed by index (zero based) from string. *----------------------------------------------------------------------------- */ static int TclX_CindexObjCmd (dummy, interp, objc, objv) ClientData dummy; Tcl_Interp *interp; int objc; Tcl_Obj *CONST objv[]; { int strLen, utfLen, idx, numBytes; char *str, buf [TCL_UTF_MAX]; if (objc != 3) return TclX_WrongArgs (interp, objv[0], "string indexExpr"); str = Tcl_GetStringFromObj (objv[1], &strLen); utfLen = Tcl_NumUtfChars(str, strLen); if (TclX_RelativeExpr (interp, objv [2], utfLen, &idx) != TCL_OK) { return TCL_ERROR; } if ((idx < 0) || (idx >= utfLen)) return TCL_OK; numBytes = Tcl_UniCharToUtf(Tcl_UniCharAtIndex(str, idx), buf); Tcl_SetStringObj (Tcl_GetObjResult (interp), buf, numBytes); return TCL_OK; } /*----------------------------------------------------------------------------- * TclX_ClengthObjCmd -- * Implements the clength Tcl command: * clength string * * Results: * Returns the length of string in characters. *----------------------------------------------------------------------------- */ static int TclX_ClengthObjCmd (dummy, interp, objc, objv) ClientData dummy; Tcl_Interp *interp; int objc; Tcl_Obj *CONST objv[]; { char *str; int strLen; if (objc != 2) return TclX_WrongArgs (interp, objv[0], "string"); str = Tcl_GetStringFromObj (objv[1], &strLen); Tcl_SetIntObj (Tcl_GetObjResult (interp), Tcl_NumUtfChars(str, strLen)); return TCL_OK; } /*----------------------------------------------------------------------------- * TclX_CconcatObjCmd -- * Implements the cconcat TclX command: * cconcat ?string? ?string? ?...? * * Results: * The arguments concatenated. *----------------------------------------------------------------------------- */ static int TclX_CconcatObjCmd (dummy, interp, objc, objv) ClientData dummy; Tcl_Interp *interp; int objc; Tcl_Obj *CONST objv[]; { Tcl_Obj *resultPtr = Tcl_GetObjResult(interp); int idx, strLen; char *str; for (idx = 1; idx < objc; idx++) { str = Tcl_GetStringFromObj(objv[idx], &strLen); Tcl_AppendToObj(resultPtr, str, strLen); } return TCL_OK; } /*----------------------------------------------------------------------------- * TclX_CrangeObjCmd -- * Implements the crange and csubstr Tcl commands: * crange string firstExpr lastExpr * csubstr string firstExpr lengthExpr * * Results: * Standard Tcl result. * Notes: * If clientData is TRUE its the range command, if its FALSE its csubstr. *----------------------------------------------------------------------------- */ static int TclX_CrangeObjCmd (clientData, interp, objc, objv) ClientData clientData; Tcl_Interp *interp; int objc; Tcl_Obj *CONST objv[]; { int strLen, utfLen, first, subLen; size_t isRange = (size_t) clientData; char *str; CONST84 char *start, *end; if (objc != 4) { if (isRange) return TclX_WrongArgs (interp, objv[0], "string firstExpr lastExpr"); else return TclX_WrongArgs (interp, objv[0], "string firstExpr lengthExpr"); } str = Tcl_GetStringFromObj (objv [1], &strLen); utfLen = Tcl_NumUtfChars(str, strLen); if (TclX_RelativeExpr (interp, objv [2], utfLen, &first) != TCL_OK) { return TCL_ERROR; } if ((first < 0) || (first >= utfLen)) return TCL_OK; if (TclX_RelativeExpr (interp, objv [3], utfLen, &subLen) != TCL_OK) { return TCL_ERROR; } if (isRange) { if (subLen < first) return TCL_OK; subLen = subLen - first +1; } if (first + subLen > utfLen) subLen = utfLen - first; start = Tcl_UtfAtIndex(str, first); end = Tcl_UtfAtIndex(start, subLen); Tcl_SetStringObj(Tcl_GetObjResult(interp), start, end - start); return TCL_OK; } /*----------------------------------------------------------------------------- * TclX_CcollateObjCmd -- * Implements ccollate Tcl commands: * ccollate [-local] string1 string2 * * Results: * Standard Tcl result. *----------------------------------------------------------------------------- */ static int TclX_CcollateObjCmd (dummy, interp, objc, objv) ClientData dummy; Tcl_Interp *interp; int objc; Tcl_Obj *CONST objv[]; { int argIndex, result, local = FALSE; char *optionString; char *string1; int string1Len; char *string2; int string2Len; /*FIX: Not utf clean (FIXUTF), can it ever be... */ if ((objc < 3) || (objc > 4)) return TclX_WrongArgs (interp, objv[0], "?options? string1 string2"); if (objc == 4) { optionString = Tcl_GetStringFromObj (objv [1], NULL); if (!STREQU (optionString, "-local")) { TclX_AppendObjResult (interp, "Invalid option \"", optionString, "\", expected \"-local\"", (char *) NULL); return TCL_ERROR; } local = TRUE; } argIndex = objc - 2; string1 = Tcl_GetStringFromObj (objv [argIndex], &string1Len); string2 = Tcl_GetStringFromObj (objv [argIndex + 1], &string2Len); if ((strlen (string1) != (size_t) string1Len) || (strlen (string1) != (size_t) string1Len)) { TclX_AppendObjResult (interp, "The " , Tcl_GetStringFromObj (objv [0], NULL), " command does not support binary data", (char *) NULL); return TCL_ERROR; } if (local) { #ifndef NO_STRCOLL result = strcoll (string1, string2); #else result = strcmp (string1, string2); #endif } else { result = strcmp (string1, string2); } Tcl_SetIntObj (Tcl_GetObjResult (interp), ((result == 0) ? 0 : ((result < 0) ? -1 : 1))); return TCL_OK; } /*----------------------------------------------------------------------------- * TclX_ReplicateObjCmd -- * Implements the replicate Tcl command: * replicate string countExpr * * Results: * Returns string replicated count times. *----------------------------------------------------------------------------- */ static int TclX_ReplicateObjCmd (dummy, interp, objc, objv) ClientData dummy; Tcl_Interp *interp; int objc; Tcl_Obj *CONST objv[]; { Tcl_Obj *resultPtr = Tcl_GetObjResult (interp); long count; long repCount; char *stringPtr; int stringLength; if (objc != 3) return TclX_WrongArgs (interp, objv[0], "string countExpr"); if (Tcl_GetLongFromObj (interp, objv [2], &repCount) != TCL_OK) return TCL_ERROR; stringPtr = Tcl_GetStringFromObj (objv [1], &stringLength); for (count = 0; count < repCount; count++) { Tcl_AppendToObj (resultPtr, stringPtr, stringLength); } return TCL_OK; } /*----------------------------------------------------------------------------- * TclX_CtokenObjCmd -- * Implements the clength Tcl command: * ctoken strvar separators * * Results: * Returns the first token and removes it from the string variable. * FIX: Add command to make a list. Better yet, a new cparse command thats * more flexable and includes this functionality. *----------------------------------------------------------------------------- */ static int TclX_CtokenObjCmd (dummy, interp, objc, objv) ClientData dummy; Tcl_Interp *interp; int objc; Tcl_Obj *CONST objv[]; { Tcl_Obj* stringVarObj; char* string; int strByteLen; int strByteIdx; char* separators; int separatorsLen; int tokenByteIdx; int tokenByteLen; Tcl_DString token; Tcl_UniChar uniChar; int utfBytes; Tcl_Obj *newVarValueObj; if (objc != 3) { return TclX_WrongArgs(interp, objv[0], "strvar separators"); } stringVarObj = Tcl_ObjGetVar2(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG|TCL_PARSE_PART1); if (stringVarObj == NULL) { return TCL_ERROR; } string = Tcl_GetStringFromObj(stringVarObj, &strByteLen); separators = Tcl_GetStringFromObj(objv[2], &separatorsLen); /* Find the start of the token */ strByteIdx = 0; while (strByteIdx < strByteLen) { utfBytes = Tcl_UtfToUniChar(string+strByteIdx, &uniChar); if (Tcl_UtfFindFirst(separators, uniChar) == NULL) { break; /* Reached a separator */ } strByteIdx += utfBytes; } tokenByteIdx = strByteIdx; /* Find end of the token */ while (strByteIdx < strByteLen) { utfBytes = Tcl_UtfToUniChar(string+strByteIdx, &uniChar); if (Tcl_UtfFindFirst(separators, uniChar) != NULL) { break; /* Reached a separator */ } strByteIdx += utfBytes; } tokenByteLen = strByteIdx-tokenByteIdx; /* Copy token, before replacing variable, as its coming from old var */ Tcl_DStringInit(&token); Tcl_DStringAppend(&token, string+tokenByteIdx, tokenByteLen); /* Set variable argument to new string. */ newVarValueObj = Tcl_NewStringObj(string+strByteIdx, strByteLen-strByteIdx); if (Tcl_SetVar2Ex(interp, Tcl_GetStringFromObj(objv[1], NULL), NULL, newVarValueObj, TCL_LEAVE_ERR_MSG|TCL_PARSE_PART1) == NULL) { Tcl_DStringFree (&token); Tcl_DecrRefCount (newVarValueObj); return TCL_ERROR; } Tcl_DStringResult(interp, &token); return TCL_OK; } /*----------------------------------------------------------------------------- * TclX_CequalObjCmd -- * Implements the cexpand Tcl command: * cequal string1 string2 * * Results: * "0" or "1". *----------------------------------------------------------------------------- */ static int TclX_CequalObjCmd (dummy, interp, objc, objv) ClientData dummy; Tcl_Interp *interp; int objc; Tcl_Obj *CONST objv[]; { char *string1Ptr; int string1Len; char *string2Ptr; int string2Len; if (objc != 3) return TclX_WrongArgs (interp, objv[0], "string1 string2"); string1Ptr = Tcl_GetStringFromObj (objv[1], &string1Len); string2Ptr = Tcl_GetStringFromObj (objv[2], &string2Len); Tcl_SetBooleanObj (Tcl_GetObjResult (interp), ((string1Len == string2Len) && (*string1Ptr == *string2Ptr) && (memcmp (string1Ptr, string2Ptr, string1Len) == 0))); return TCL_OK; } /*----------------------------------------------------------------------------- * Check for non-ascii characters in a translit string until we actually * make it work for UniCode. *----------------------------------------------------------------------------- */ static int CheckForUniCode(interp, str, strLen, which) Tcl_Interp *interp; char *str; int strLen; char *which; { int idx, nbytes; Tcl_UniChar uc; for (idx = 0; idx < strLen; idx++) { nbytes = Tcl_UtfToUniChar(&str[idx], &uc); if (nbytes != 1) { Tcl_AppendResult(interp, "Unicode character found in ", which, ", the translit command does not yet support Unicode", (char*)NULL); return TCL_ERROR; } } return TCL_OK; } /*----------------------------------------------------------------------------- * ExpandString -- * Build an expand version of a translit range specification. * * Results: * The number of characters in the expansion buffer or < 0 if the maximum * expansion has been exceeded. *----------------------------------------------------------------------------- */ #define MAX_EXPANSION 255 static unsigned int ExpandString(inStr, inLength, outStr, outLengthPtr) unsigned char *inStr; int inLength; unsigned char outStr []; int *outLengthPtr; { int i, j; unsigned char *s = inStr; unsigned char *inStrLimit = inStr + inLength; i = 0; while((s < inStrLimit) && (i < MAX_EXPANSION)) { if ((s [1] == '-') && (s [2] > s [0])) { for (j = s [0]; j <= s [2]; j++) { outStr [i++] = j; } s += 3; } else { outStr [i++] = *s++; } } *outLengthPtr = i; return (i < MAX_EXPANSION); } /*----------------------------------------------------------------------------- * TclX_TranslitObjCmd -- * Implements the Tcl translit command: * translit inrange outrange string * * Results: * Standard Tcl results. * FIXME: Does not currently support non-ascii characters. *----------------------------------------------------------------------------- */ static int TclX_TranslitObjCmd (dummy, interp, objc, objv) ClientData dummy; Tcl_Interp *interp; int objc; Tcl_Obj *CONST objv[]; { unsigned char from [MAX_EXPANSION+1]; int fromLen; unsigned char to [MAX_EXPANSION+1]; int toLen; short map [MAX_EXPANSION+1]; unsigned char *s; char *fromString; int fromStringLen; char *toString; int toStringLen; Tcl_Obj *transStringObj; char *transString; int transStringLen; int idx; int stringIndex; /*FIX: Not UTF-safe.(FIXUTF) */ if (objc != 4) return TclX_WrongArgs (interp, objv[0], "from to string"); /* * Expand ranges into descrete values. */ fromString = Tcl_GetStringFromObj (objv[1], &fromStringLen); if (CheckForUniCode(interp, fromString, fromStringLen, "in-range") != TCL_OK) { return TCL_ERROR; } if (!ExpandString ((unsigned char *) fromString, fromStringLen, from, &fromLen)) { TclX_AppendObjResult (interp, "inrange expansion too long", (char *) NULL); return TCL_ERROR; } toString = Tcl_GetStringFromObj (objv [2], &toStringLen); if (CheckForUniCode(interp, toString, toStringLen, "out-range") != TCL_OK) { return TCL_ERROR; } if (!ExpandString ((unsigned char *) toString, toStringLen, to, &toLen)) { TclX_AppendObjResult (interp, "outrange expansion too long", (char *) NULL); return TCL_ERROR; } if (fromLen > toLen) { TclX_AppendObjResult (interp, "inrange longer than outrange", (char *) NULL); return TCL_ERROR; } /* * Build map. Entries of -1 discard the char. All other values are * positive (hence its a short). */ for (idx = 0; idx <= MAX_EXPANSION; idx++) { map [idx] = idx; } for (idx = 0; (idx < toLen) && (idx < fromLen); idx++) { map [from [idx]] = to [idx]; } for (; idx < fromLen; idx++) map [from [idx]] = -1; /* * Get a string object to transform. */ transString = Tcl_GetStringFromObj (objv[3], &transStringLen); if (CheckForUniCode(interp, transString, transStringLen, "string to translate") != TCL_OK) { return TCL_ERROR; } transStringObj = Tcl_NewStringObj (transString, transStringLen); transString = Tcl_GetStringFromObj (transStringObj, &transStringLen); for (s = (unsigned char *) transString, stringIndex = 0; stringIndex < transStringLen; stringIndex++) { if (map [*s] >= 0) { *s = (unsigned char) map [*s]; s++; } } Tcl_SetObjResult (interp, transStringObj); return TCL_OK; } /*----------------------------------------------------------------------------- * TclX_CtypeObjCmd -- * * This function implements the 'ctype' command: * ctype ?-failindex? class string ?failIndexVar? * * Where class is one of the following: * digit, xdigit, lower, upper, alpha, alnum, * space, cntrl, punct, print, graph, ascii, char or ord. * * Results: * One or zero: Depending if all the characters in the string are of * the desired class. Char and ord provide conversions and return the * converted value. * FIX: Add check for legal number (can be negative, hex, etc). *----------------------------------------------------------------------------- */ static int TclX_CtypeObjCmd (dummy, interp, objc, objv) ClientData dummy; Tcl_Interp *interp; int objc; Tcl_Obj *CONST objv[]; { int failIndex = FALSE; char *optStr, *class, *charStr; int charStrLen, cnt, idx; char *failVar = NULL; Tcl_Obj *classObj, *stringObj; int number; char charBuf[TCL_UTF_MAX]; Tcl_UniChar uniChar; #define IS_8BIT_UNICHAR(c) (c <= 255) if (TCL_UTF_MAX > sizeof(number)) { panic("TclX_CtypeObjCmd: UTF character longer than a int"); } /*FIX: Split into multiple procs */ /*FIX: Should use UtfNext to walk string */ if (objc < 3) { goto wrongNumArgs; } optStr = Tcl_GetStringFromObj(objv[1], NULL); if (*optStr == '-') { if (STREQU(optStr, "-failindex")) { failIndex = TRUE; } else { TclX_AppendObjResult(interp, "invalid option \"", Tcl_GetStringFromObj (objv [1], NULL), "\", must be -failindex", (char *) NULL); return TCL_ERROR; } } if (failIndex) { if (objc != 5) { goto wrongNumArgs; } failVar = Tcl_GetStringFromObj(objv[2], NULL); classObj = objv[3]; stringObj = objv[4]; } else { if (objc != 3) { goto wrongNumArgs; } classObj = objv[1]; stringObj = objv[2]; } charStr = Tcl_GetStringFromObj(stringObj, &charStrLen); charStrLen = Tcl_NumUtfChars(charStr, charStrLen); class = Tcl_GetStringFromObj(classObj, NULL); /* * Handle conversion requests. */ if (STREQU(class, "char")) { if (failIndex) { goto failInvalid; } if (Tcl_GetIntFromObj(interp, stringObj, &number) != TCL_OK) { return TCL_ERROR; } cnt = Tcl_UniCharToUtf(number, charBuf); charBuf[cnt] = '\0'; Tcl_SetStringObj(Tcl_GetObjResult(interp), charBuf, cnt); return TCL_OK; } if (STREQU(class, "ord")) { if (failIndex) { goto failInvalid; } Tcl_UtfToUniChar(charStr, &uniChar); Tcl_SetIntObj(Tcl_GetObjResult(interp), (int)uniChar); return TCL_OK; } /* * The remainder of cases scan the string, stoping when their test case * fails. The value of `index' after the loops indicating if it succeeds * or fails and where it fails. */ if (STREQU(class, "alnum")) { for (idx = 0; idx < charStrLen; idx++) { if (!Tcl_UniCharIsAlnum(Tcl_UniCharAtIndex(charStr, idx))) { break; } } } else if (STREQU(class, "alpha")) { for (idx = 0; idx < charStrLen; idx++) { if (!Tcl_UniCharIsAlpha(Tcl_UniCharAtIndex(charStr, idx))) { break; } } } else if (STREQU(class, "ascii")) { for (idx = 0; idx < charStrLen; idx++) { uniChar = Tcl_UniCharAtIndex(charStr, idx); if (!IS_8BIT_UNICHAR(uniChar) || !isascii(UCHAR(uniChar))) { break; } } } else if (STREQU(class, "cntrl")) { for (idx = 0; idx < charStrLen; idx++) { uniChar = Tcl_UniCharAtIndex(charStr, idx); /* Only accepts ascii controls */ if (!IS_8BIT_UNICHAR(uniChar) || !iscntrl(UCHAR(uniChar))) { break; } } } else if (STREQU(class, "digit")) { for (idx = 0; idx < charStrLen; idx++) { if (!Tcl_UniCharIsDigit(Tcl_UniCharAtIndex(charStr, idx))) { break; } } } else if (STREQU(class, "graph")) { for (idx = 0; idx < charStrLen; idx++) { uniChar = Tcl_UniCharAtIndex(charStr, idx); if (!IS_8BIT_UNICHAR(uniChar)) { goto notSupportedUni; } if (!isgraph(UCHAR(uniChar))) { break; } } } else if (STREQU(class, "lower")) { for (idx = 0; idx < charStrLen; idx++) { if (!Tcl_UniCharIsLower(Tcl_UniCharAtIndex(charStr, idx))) { break; } } } else if (STREQU(class, "print")) { for (idx = 0; idx < charStrLen; idx++) { uniChar = Tcl_UniCharAtIndex(charStr, idx); if (!IS_8BIT_UNICHAR(uniChar)) { goto notSupportedUni; } if (!isprint(UCHAR(uniChar))) { break; } } } else if (STREQU(class, "punct")) { for (idx = 0; idx < charStrLen; idx++) { uniChar = Tcl_UniCharAtIndex(charStr, idx); if (!IS_8BIT_UNICHAR(uniChar)) { goto notSupportedUni; } if (!ispunct(UCHAR(uniChar))) { break; } } } else if (STREQU(class, "space")) { for (idx = 0; idx < charStrLen; idx++) { if (!Tcl_UniCharIsSpace(Tcl_UniCharAtIndex(charStr, idx))) { break; } } } else if (STREQU(class, "upper")) { for (idx = 0; idx < charStrLen; idx++) { if (!Tcl_UniCharIsUpper(Tcl_UniCharAtIndex(charStr, idx))) { break; } } } else if (STREQU(class, "xdigit")) { for (idx = 0; idx < charStrLen; idx++) { uniChar = Tcl_UniCharAtIndex(charStr, idx); if (!IS_8BIT_UNICHAR(uniChar)) { goto notSupportedUni; } if (!isxdigit(UCHAR(uniChar))) { break; } } } else { TclX_AppendObjResult (interp, "unrecognized class specification: \"", class, "\", expected one of: alnum, alpha, ascii, ", "char, cntrl, digit, graph, lower, ord, ", "print, punct, space, upper or xdigit", (char *) NULL); return TCL_ERROR; } /* * Return true or false, depending if the end was reached. Always return * false for a null string. Optionally return the failed index if there * is no match. */ if ((idx != 0) && (idx == charStrLen)) { Tcl_SetBooleanObj (Tcl_GetObjResult (interp), TRUE); } else { /* * If the fail index was requested, set the variable here. */ if (failIndex) { Tcl_Obj *iObj = Tcl_NewIntObj (idx); if (Tcl_SetVar2Ex(interp, failVar, NULL, iObj, TCL_LEAVE_ERR_MSG|TCL_PARSE_PART1) == NULL) { Tcl_DecrRefCount (iObj); return TCL_ERROR; } } Tcl_SetBooleanObj (Tcl_GetObjResult (interp), FALSE); } return TCL_OK; wrongNumArgs: return TclX_WrongArgs (interp, objv[0], "?-failindex var? class string"); failInvalid: TclX_AppendObjResult (interp, "-failindex option is invalid for class \"", class, "\"", (char *) NULL); return TCL_ERROR; notSupportedUni: TclX_AppendObjResult (interp, "unicode characters not supported for class \"", class, "\"", (char *) NULL); return TCL_ERROR; } /*----------------------------------------------------------------------------- * TclX_StringInit -- * Initialize the list commands in an interpreter. * * Parameters: * o interp - Interpreter to add commands to. *----------------------------------------------------------------------------- */ void TclX_StringInit (interp) Tcl_Interp *interp; { Tcl_CreateObjCommand (interp, "cindex", TclX_CindexObjCmd, (ClientData) 0, (Tcl_CmdDeleteProc*) NULL); Tcl_CreateObjCommand (interp, "clength", TclX_ClengthObjCmd, (ClientData) 0, (Tcl_CmdDeleteProc *)NULL); Tcl_CreateObjCommand (interp, "cconcat", TclX_CconcatObjCmd, (ClientData) 0, (Tcl_CmdDeleteProc *)NULL); Tcl_CreateObjCommand (interp, "crange", TclX_CrangeObjCmd, (ClientData) TRUE, (Tcl_CmdDeleteProc*) NULL); Tcl_CreateObjCommand (interp, "csubstr", TclX_CrangeObjCmd, (ClientData) FALSE, (Tcl_CmdDeleteProc*) NULL); Tcl_CreateObjCommand (interp, "ccollate", TclX_CcollateObjCmd, (ClientData) 0, (Tcl_CmdDeleteProc*) NULL); Tcl_CreateObjCommand (interp, "replicate", TclX_ReplicateObjCmd, (ClientData) 0, (Tcl_CmdDeleteProc*) NULL); Tcl_CreateObjCommand (interp, "translit", TclX_TranslitObjCmd, (ClientData) 0, (Tcl_CmdDeleteProc*) NULL); Tcl_CreateObjCommand (interp, "ctype", TclX_CtypeObjCmd, (ClientData) 0, (Tcl_CmdDeleteProc*) NULL); Tcl_CreateObjCommand (interp, "ctoken", TclX_CtokenObjCmd, (ClientData) 0, (Tcl_CmdDeleteProc*) NULL); Tcl_CreateObjCommand (interp, "cequal", TclX_CequalObjCmd, (ClientData) 0, (Tcl_CmdDeleteProc*) NULL); } tclx8.4-8.4.1.orig/generic/tclXmsgcat.c0000644000000000000000000002711612046313170014452 0ustar /* * tclXmsgcat.c -- * * Contains commands for accessing XPG/3 message catalogs. If real XPG/3 * message catalogs are not available, the default string is returned. *----------------------------------------------------------------------------- * Copyright 1991-1999 Karl Lehenbauer and Mark Diekhans. * * Permission to use, copy, modify, and distribute this software and its * documentation for any purpose and without fee is hereby granted, provided * that the above copyright notice appear in all copies. Karl Lehenbauer and * Mark Diekhans make no representations about the suitability of this * software for any purpose. It is provided "as is" without express or * implied warranty. *----------------------------------------------------------------------------- * $Id: tclXmsgcat.c,v 1.1 2001/10/24 23:31:48 hobbs Exp $ *----------------------------------------------------------------------------- */ #include "tclExtdInt.h" #ifndef NO_CATGETS #include #else typedef int nl_catd; #endif /* NO_CATGETS */ static int ParseFailOptionObj _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *optionObj, int *failPtr)); static int CatOpFailedObj _ANSI_ARGS_((Tcl_Interp *interp, CONST char *errorMsg)); static int TclX_CatopenObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int TclX_CatgetsObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int TclX_CatcloseObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static void MsgCatCleanUp _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp)); /* * Message catalog table is global, so it is shared between all interpreters * in the same process. */ static void_pt msgCatTblPtr = NULL; #ifdef NO_CATGETS /*----------------------------------------------------------------------------- * catopen -- * * A stub to use when message catalogs are not available. Always returns * -1. *----------------------------------------------------------------------------- */ static nl_catd catopen (name, oflag) char *name; int oflag; { return (nl_catd) -1; } /*----------------------------------------------------------------------------- * catgets -- * * A stub to use when message catalogs are not available. Always returns * the default string. *----------------------------------------------------------------------------- */ static char * catgets (catd, set_num, msg_num, defaultStr) nl_catd catd; int set_num, msg_num; char *defaultStr; { return defaultStr; } /*----------------------------------------------------------------------------- * catclose -- * * A stub to use when message catalogs are not available. Always returns -1. *----------------------------------------------------------------------------- */ static int catclose (catd) nl_catd catd; { return -1; } #endif /* NO_CATGETS */ /*----------------------------------------------------------------------------- * ParseFailOptionObj -- * * Parse the -fail/-nofail option, if specified. *----------------------------------------------------------------------------- */ static int ParseFailOptionObj (interp, optionObj, failPtr) Tcl_Interp *interp; Tcl_Obj *optionObj; int *failPtr; { char *optionStr; optionStr = Tcl_GetStringFromObj (optionObj, NULL); if (STREQU ("-fail", optionStr)) *failPtr = TRUE; else if (STREQU ("-nofail", optionStr)) *failPtr = FALSE; else { TclX_AppendObjResult (interp, "Expected option of `-fail' or ", "`-nofail', got: `", optionStr, "'", (char *) NULL); return TCL_ERROR; } return TCL_OK; } /*----------------------------------------------------------------------------- * CatOpFailedObj -- * * Handles failures of catopen and catclose. If message catalogs are * available, if returns the supplied message. If message are not * available, it returns a message indicating that message stubs are used. * It is not specified by XPG/3 how to get the details of a message catalog * open or close failure. Always returns TCL_ERROR; *----------------------------------------------------------------------------- */ static int CatOpFailedObj (interp, errorMsg) Tcl_Interp *interp; CONST char *errorMsg; { #ifndef NO_CATGETS TclX_AppendObjResult (interp, errorMsg, (char *) NULL); #else TclX_AppendObjResult (interp, "the message catalog facility is not", " available, default string is always returned", (char *) NULL); #endif /* NO_CATGETS */ return TCL_ERROR; } /*----------------------------------------------------------------------------- * TclX_CatopenObjCmd -- * * Implements the TCLX catopen command: * catopen ?-fail|-nofail? catname *----------------------------------------------------------------------------- */ static int TclX_CatopenObjCmd (clientData, interp, objc, objv) ClientData clientData; Tcl_Interp *interp; int objc; Tcl_Obj *CONST objv[]; { int fail; nl_catd catDesc; nl_catd *catDescPtr; char handleName[16]; char *catFileName; if ((objc < 2) || (objc > 3)) return TclX_WrongArgs (interp, objv [0], "?-fail|-nofail? catname"); if (objc == 3) { if (ParseFailOptionObj (interp, objv [1], &fail) == TCL_ERROR) return TCL_ERROR; } else fail = FALSE; catFileName = Tcl_GetStringFromObj (objv [objc - 1], NULL); catDesc = catopen (catFileName, 0); if ((catDesc == (nl_catd) -1) && fail) return CatOpFailedObj (interp, "open of message catalog failed"); catDescPtr = (nl_catd *) TclX_HandleAlloc (msgCatTblPtr, handleName); *catDescPtr = catDesc; Tcl_SetObjResult (interp, Tcl_NewStringObj (handleName, -1)); return TCL_OK; } /*----------------------------------------------------------------------------- * TclX_CatgetsObjCmd -- * * Implements the TCLX catgets command: * catgets catHandle setnum msgnum defaultstr *----------------------------------------------------------------------------- */ static int TclX_CatgetsObjCmd (clientData, interp, objc, objv) ClientData clientData; Tcl_Interp *interp; int objc; Tcl_Obj *CONST objv[]; { nl_catd *catDescPtr; int msgSetNum, msgNum; char *localMsg; char *defaultStr; if (objc != 5) return TclX_WrongArgs (interp, objv [0], "catHandle setnum msgnum defaultstr"); catDescPtr = (nl_catd *) TclX_HandleXlateObj (interp, msgCatTblPtr, objv [1]); if (catDescPtr == NULL) return TCL_ERROR; if (Tcl_GetIntFromObj (interp, objv [2], &msgSetNum) == TCL_ERROR) return TCL_ERROR; if (Tcl_GetIntFromObj (interp, objv [3], &msgNum) == TCL_ERROR) return TCL_ERROR; /* * if the integer value of the handle is -1, the catopen actually * failed (softly, i.e. the caller did not specify "-fail") * so we detect that and merely return the default string. */ if (*catDescPtr == (nl_catd)-1) { Tcl_SetObjResult (interp, objv [4]); Tcl_IncrRefCount (objv [4]); return TCL_OK; } defaultStr = Tcl_GetStringFromObj (objv [4], NULL); localMsg = catgets (*catDescPtr, (int)msgSetNum, (int)msgNum, defaultStr); Tcl_SetObjResult (interp, Tcl_NewStringObj (localMsg, -1)); return TCL_OK; } /*----------------------------------------------------------------------------- * TclX_CatcloseObjCmd -- * * Implements the TCLX catclose command: * catclose ?-fail|-nofail? catHandle *----------------------------------------------------------------------------- */ static int TclX_CatcloseObjCmd (clientData, interp, objc, objv) ClientData clientData; Tcl_Interp *interp; int objc; Tcl_Obj *CONST objv[]; { int fail; nl_catd *catDescPtr; int result = 0; if ((objc < 2) || (objc > 3)) return TclX_WrongArgs (interp, objv [0], "?-fail|-nofail? catHandle"); if (objc == 3) { if (ParseFailOptionObj (interp, objv [1], &fail) != TCL_OK) return TCL_ERROR; } else fail = FALSE; catDescPtr = (nl_catd *) TclX_HandleXlateObj (interp, msgCatTblPtr, objv [objc - 1]); if (catDescPtr == NULL) return TCL_ERROR; /* If the integer returned by catopen is -1, signifying that the * open failed but "-fail" was not specified to actually force * the failure, we don't close the catalog, but we do delete * the handle. */ if (*catDescPtr == (nl_catd)-1) { result = -1; } else { /* * NetBSD has catclose of return type void, which is non-standard. */ #ifdef BAD_CATCLOSE catclose (*catDescPtr); #else result = catclose (*catDescPtr); #endif } TclX_HandleFree (msgCatTblPtr, catDescPtr); if ((result < 0) && fail) return CatOpFailedObj (interp, "close of message catalog failed"); return TCL_OK; } /*----------------------------------------------------------------------------- * MsgCatCleanUp -- * * Called at interpreter deletion. Releases all resources when no more * interpreters are using the message catalog table. *----------------------------------------------------------------------------- */ static void MsgCatCleanUp (clientData, interp) ClientData clientData; Tcl_Interp *interp; { nl_catd *catDescPtr; int walkKey; if (TclX_HandleTblUseCount (msgCatTblPtr, -1) > 0) return; walkKey = -1; while (TRUE) { catDescPtr = (nl_catd *) TclX_HandleWalk (msgCatTblPtr, &walkKey); if (catDescPtr == NULL) break; if (*catDescPtr != (nl_catd)-1) catclose (*catDescPtr); } TclX_HandleTblRelease (msgCatTblPtr); msgCatTblPtr = NULL; } /*----------------------------------------------------------------------------- * TclX_MsgCatInit -- * * Initialize the Tcl XPG/3 message catalog support faility. *----------------------------------------------------------------------------- */ void TclX_MsgCatInit (interp) Tcl_Interp *interp; { /* * Set up the table. It is shared between all interpreters, so the use * count reflects the number of interpreters. */ if (msgCatTblPtr == NULL) { msgCatTblPtr = TclX_HandleTblInit ("msgcat", sizeof (nl_catd), 6); } else { (void) TclX_HandleTblUseCount (msgCatTblPtr, 1); } Tcl_CallWhenDeleted (interp, MsgCatCleanUp, (ClientData) NULL); /* * Initialize the commands. */ Tcl_CreateObjCommand (interp, "catopen", TclX_CatopenObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc*) NULL); Tcl_CreateObjCommand (interp, "catgets", TclX_CatgetsObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc*) NULL); Tcl_CreateObjCommand (interp, "catclose", TclX_CatcloseObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc*) NULL); } tclx8.4-8.4.1.orig/generic/tclXsocket.c0000644000000000000000000002234712046313170014465 0ustar /* * tclXsocket.c -- * * Socket utility functions and commands. *--------------------------------------------------------------------------- * Copyright 1991-1999 Karl Lehenbauer and Mark Diekhans. * * Permission to use, copy, modify, and distribute this software and its * documentation for any purpose and without fee is hereby granted, provided x * that the above copyright notice appear in all copies. Karl Lehenbauer and * Mark Diekhans make no representations about the suitability of this * software for any purpose. It is provided "as is" without express or * implied warranty. *----------------------------------------------------------------------------- * $Id: tclXsocket.c,v 1.2 2004/05/24 23:11:52 hobbs Exp $ *----------------------------------------------------------------------------- */ #include "tclExtdInt.h" /* * Prototypes of internal functions. */ static int ReturnGetHostError _ANSI_ARGS_((Tcl_Interp *interp, char *host)); static struct hostent * InfoGetHost _ANSI_ARGS_((Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int TclX_HostInfoObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); /*----------------------------------------------------------------------------- * ReturnGetHostError -- * * Return an error message when gethostbyname or gethostbyaddr fails. * * Parameters: * o interp (O) - The error message is returned in the result. * o host (I) - Host name or address that got the error. * Globals: * o h_errno (I) - The list of file handles to parse, may be empty. * Returns: * Always returns TCL_ERROR. *----------------------------------------------------------------------------- */ static int ReturnGetHostError (interp, host) Tcl_Interp *interp; char *host; { char *errorMsg; char *errorCode; switch (h_errno) { case HOST_NOT_FOUND: errorCode = "HOST_NOT_FOUND"; errorMsg = "host not found"; break; case TRY_AGAIN: errorCode = "TRY_AGAIN"; errorMsg = "try again"; break; case NO_RECOVERY: errorCode = "NO_RECOVERY"; errorMsg = "unrecordable server error"; break; #ifdef NO_DATA case NO_DATA: errorCode = "NO_DATA"; errorMsg = "no data"; break; #endif default: errorCode = "UNKNOWN_ERROR"; errorMsg = "unknown error"; } Tcl_SetErrorCode (interp, "INET", errorCode, errorMsg, (char *)NULL); TclX_AppendObjResult (interp, "host lookup failure: ", host, " (", errorMsg, ")", (char *) NULL); return TCL_ERROR; } /*----------------------------------------------------------------------------- * TclXGetHostInfo -- * Return a host address, name (if it can be obtained) and port number. * Used by the fstat command. * * Parameters: * o interp (O) - Error messages are returned in the result. * o channel (I) - Channel associated with the socket. * o remoteHost (I) - TRUE to get remote host information, FALSE to get * local host info. * Returns: * An object with the list of information, or NULL if an error occured. *----------------------------------------------------------------------------- */ Tcl_Obj * TclXGetHostInfo (interp, channel, remoteHost) Tcl_Interp *interp; Tcl_Channel channel; int remoteHost; { struct sockaddr_in sockaddr; struct hostent *hostEntry; CONST char *hostName; Tcl_Obj *listObjv [3]; if (remoteHost) { if (TclXOSgetpeername (interp, channel, &sockaddr, sizeof (sockaddr)) != TCL_OK) return NULL; } else { if (TclXOSgetsockname (interp, channel, &sockaddr, sizeof (sockaddr)) != TCL_OK) return NULL; } hostEntry = gethostbyaddr ((char *) &(sockaddr.sin_addr), sizeof (sockaddr.sin_addr), AF_INET); if (hostEntry != NULL) hostName = hostEntry->h_name; else hostName = ""; listObjv [0] = Tcl_NewStringObj (inet_ntoa (sockaddr.sin_addr), -1); listObjv [1] = Tcl_NewStringObj ((char *) hostName, -1); listObjv [2] = Tcl_NewIntObj (ntohs (sockaddr.sin_port)); return Tcl_NewListObj (3, listObjv); } /*----------------------------------------------------------------------------- * InfoGetHost -- * * Validate arguments and call gethostbyaddr for the host_info options * that return info about a host. This looks up host information either by * name or address. * * Parameters: * o interp (O) - The error message is returned in the result. * o objc, objv (I) - Command argments as Tcl objects. Host name or IP * address is expected in objv [2]. * Returns: * Pointer to the host entry or NULL if an error occured. *----------------------------------------------------------------------------- */ static struct hostent * InfoGetHost (interp, objc, objv) Tcl_Interp *interp; int objc; Tcl_Obj *CONST objv[]; { struct hostent *hostEntry; struct in_addr address; char *command = Tcl_GetStringFromObj (objv [0], NULL); char *subCommand = Tcl_GetStringFromObj (objv [1], NULL); char *host; if (objc != 3) { TclX_AppendObjResult (interp, tclXWrongArgs, command, " ", subCommand, " host", (char *) NULL); return NULL; } host = Tcl_GetStringFromObj(objv [2], NULL); if (TclXOSInetAtoN (NULL, host, &address) == TCL_OK) { hostEntry = gethostbyaddr((char *) &address, sizeof(address), AF_INET); } else { hostEntry = gethostbyname(host); } if (hostEntry == NULL) { ReturnGetHostError (interp, host); return NULL; } return hostEntry; } /*----------------------------------------------------------------------------- * TclX_HostInfoObjCmd -- * Implements the TCL host_info command: * * host_info addresses host * host_info official_name host * host_info aliases host * * Results: * For hostname, a list of address associated with the host. *----------------------------------------------------------------------------- */ static int TclX_HostInfoObjCmd (clientData, interp, objc, objv) ClientData clientData; Tcl_Interp *interp; int objc; Tcl_Obj *CONST objv[]; { struct hostent *hostEntry; struct in_addr inAddr; int idx; char *subCommand; Tcl_Obj *listObj; Tcl_Obj *resultPtr; if (objc < 2) return TclX_WrongArgs (interp, objv [0], "option ..."); resultPtr = Tcl_GetObjResult (interp); subCommand = Tcl_GetStringFromObj (objv [1], NULL); if (STREQU (subCommand, "addresses")) { hostEntry = InfoGetHost (interp, objc, objv); if (hostEntry == NULL) return TCL_ERROR; for (idx = 0; hostEntry->h_addr_list [idx] != NULL; idx++) { bcopy ((VOID *) hostEntry->h_addr_list [idx], (VOID *) &inAddr, hostEntry->h_length); listObj = Tcl_NewStringObj (inet_ntoa (inAddr), -1); Tcl_ListObjAppendElement (interp, resultPtr, listObj); } return TCL_OK; } if (STREQU (subCommand, "address_name")) { hostEntry = InfoGetHost (interp, objc, objv); if (hostEntry == NULL) return TCL_ERROR; for (idx = 0; hostEntry->h_addr_list [idx] != NULL; idx++) { bcopy ((VOID *) hostEntry->h_addr_list [idx], (VOID *) &inAddr, hostEntry->h_length); listObj = Tcl_NewStringObj ((char *) hostEntry->h_name, -1); Tcl_ListObjAppendElement (interp, resultPtr, listObj); } return TCL_OK; } if (STREQU (subCommand, "official_name")) { hostEntry = InfoGetHost (interp, objc, objv); if (hostEntry == NULL) return TCL_ERROR; Tcl_SetStringObj (resultPtr, (char *) hostEntry->h_name, -1); return TCL_OK; } if (STREQU (subCommand, "aliases")) { hostEntry = InfoGetHost (interp, objc, objv); if (hostEntry == NULL) return TCL_ERROR; for (idx = 0; hostEntry->h_aliases [idx] != NULL; idx++) { listObj = Tcl_NewStringObj (hostEntry->h_aliases [idx], -1); Tcl_ListObjAppendElement (interp, resultPtr, listObj); } return TCL_OK; } TclX_AppendObjResult (interp, "invalid option \"", subCommand, "\", expected one of \"addresses\", ", "\"official_name\", or \"aliases\"", (char *) NULL); return TCL_ERROR; } /*----------------------------------------------------------------------------- * TclX_SocketInit -- * Initialize the host_info command. *----------------------------------------------------------------------------- */ void TclX_SocketInit (interp) Tcl_Interp *interp; { Tcl_CreateObjCommand (interp, "host_info", TclX_HostInfoObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc*) NULL); } tclx8.4-8.4.1.orig/generic/tclXinit.c0000644000000000000000000000777312046313170014146 0ustar /* * tclXinit.c -- * * Extended Tcl initialzation and initialization utilitied. *----------------------------------------------------------------------------- * Copyright 1991-1999 Karl Lehenbauer and Mark Diekhans. * * Permission to use, copy, modify, and distribute this software and its * documentation for any purpose and without fee is hereby granted, provided * that the above copyright notice appear in all copies. Karl Lehenbauer and * Mark Diekhans make no representations about the suitability of this * software for any purpose. It is provided "as is" without express or * implied warranty. *----------------------------------------------------------------------------- * $Id: tclXinit.c,v 1.4 2005/03/24 05:11:15 hobbs Exp $ *----------------------------------------------------------------------------- */ #include "tclExtdInt.h" /* * Tcl procedure to search for an init for TclX startup file. */ static char initScript[] = "if {[info proc ::tclx::Init]==\"\"} {\n\ namespace eval ::tclx {}\n\ proc ::tclx::Init {} {\n" #ifdef MAC_TCL " source -rsrc tclx.tcl\n" #else " global tclx_library\n\ tcl_findLibrary tclx " PACKAGE_VERSION " " FULL_VERSION " tclx.tcl TCLX_LIBRARY tclx_library\n" #endif " }\n\ }\n\ ::tclx::Init"; /* * Prototypes of internal functions. */ static int Tclxcmd_Init _ANSI_ARGS_((Tcl_Interp *interp)); /*----------------------------------------------------------------------------- * Tclx_Init -- * * Initialize all Extended Tcl commands, set auto_path and source the * Tcl init file. *----------------------------------------------------------------------------- */ int Tclx_Init (interp) Tcl_Interp *interp; { if (Tclx_SafeInit(interp) != TCL_OK) { return TCL_ERROR; } if ((Tcl_EvalEx(interp, initScript, -1, TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT) != TCL_OK) || (TclX_LibraryInit(interp) != TCL_OK)) { Tcl_AddErrorInfo(interp, "\n (in TclX_Init)"); return TCL_ERROR; } return TCL_OK; } /*----------------------------------------------------------------------------- * Tclx_SafeInit -- * * Initialize safe Extended Tcl commands. *----------------------------------------------------------------------------- */ int Tclx_SafeInit (interp) Tcl_Interp *interp; { if ( #ifdef USE_TCL_STUBS (Tcl_InitStubs(interp, "8.0", 0) == NULL) #else (Tcl_PkgRequire(interp, "Tcl", "8.0", 0) == NULL) #endif || (Tclxcmd_Init(interp) != TCL_OK) || (Tcl_PkgProvide(interp, "Tclx", PACKAGE_VERSION) != TCL_OK) ) { Tcl_AddErrorInfo (interp, "\n (in TclX_SafeInit)"); return TCL_ERROR; } return TCL_OK; } /*----------------------------------------------------------------------------- * Tclxcmd_Init -- * * Add the Extended Tcl commands to the specified interpreter (except for * the library commands that override that standard Tcl procedures). This * does no other startup. *----------------------------------------------------------------------------- */ static int Tclxcmd_Init (interp) Tcl_Interp *interp; { /* * These are ok in safe interps. */ TclX_SetAppInfo(TRUE, "TclX", "Extended Tcl", PACKAGE_VERSION, TCLX_PATCHLEVEL); TclX_BsearchInit (interp); TclX_FstatInit (interp); TclX_FlockInit (interp); TclX_FilescanInit (interp); TclX_GeneralInit (interp); TclX_IdInit (interp); TclX_KeyedListInit (interp); TclX_LgetsInit (interp); TclX_ListInit (interp); TclX_MathInit (interp); TclX_ProfileInit (interp); TclX_SelectInit (interp); TclX_StringInit (interp); if (!Tcl_IsSafe(interp)) { /* * Add these only in trusted interps. */ TclX_ChmodInit (interp); TclX_CmdloopInit (interp); TclX_DebugInit (interp); TclX_DupInit (interp); TclX_FcntlInit (interp); TclX_FilecmdsInit (interp); TclX_FstatInit (interp); TclX_MsgCatInit (interp); TclX_ProcessInit (interp); TclX_SignalInit (interp); TclX_OsCmdsInit (interp); TclX_PlatformCmdsInit (interp); TclX_SocketInit (interp); TclX_ServerInit (interp); } return TCL_OK; } tclx8.4-8.4.1.orig/generic/tclXfstat.c0000644000000000000000000003215112046313167014316 0ustar /* * tclXfstat.c * * Extended Tcl fstat command. *----------------------------------------------------------------------------- * Copyright 1991-1999 Karl Lehenbauer and Mark Diekhans. * * Permission to use, copy, modify, and distribute this software and its * documentation for any purpose and without fee is hereby granted, provided * that the above copyright notice appear in all copies. Karl Lehenbauer and * Mark Diekhans make no representations about the suitability of this * software for any purpose. It is provided "as is" without express or * implied warranty. *----------------------------------------------------------------------------- * $Id: tclXfstat.c,v 1.1 2001/10/24 23:31:48 hobbs Exp $ *----------------------------------------------------------------------------- */ #include "tclExtdInt.h" #ifndef S_IFMT # define S_IFMT 0170000 #endif /* * Table to convert file mode to symbolic file type. Note, the S_ macros * are not used because the BSD macros don't distinguish between a fifo and * a socket. */ static struct { int intType; char *strType; } modeToSymTable [] = { {S_IFIFO, "fifo"}, {S_IFCHR, "characterSpecial"}, {S_IFDIR, "directory"}, #ifdef S_IFBLK {S_IFBLK, "blockSpecial"}, #endif {S_IFREG, "file"}, #ifdef S_IFLNK {S_IFLNK, "link"}, #endif #ifdef S_IFSOCK {S_IFSOCK, "socket"}, #endif {0, NULL} }; /* * Prototypes of internal functions. */ static char * StrFileType _ANSI_ARGS_((struct stat *statBufPtr)); static void ReturnStatList _ANSI_ARGS_((Tcl_Interp *interp, int ttyDev, struct stat *statBufPtr)); static int ReturnStatArray _ANSI_ARGS_((Tcl_Interp *interp, int ttyDev, struct stat *statBufPtr, Tcl_Obj *arrayObj)); static int ReturnStatItem _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Channel channel, int ttyDev, struct stat *statBufPtr, char *itemName)); static int TclX_FstatObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); /*----------------------------------------------------------------------------- * StrFileType -- * * Looks at stat mode and returns a text string indicating what type of * file it is. * * Parameters: * o statBufPtr (I) - Pointer to a buffer initialized by stat or fstat. * Returns: * A pointer static text string representing the type of the file. *----------------------------------------------------------------------------- */ static char * StrFileType (statBufPtr) struct stat *statBufPtr; { int idx; for (idx = 0; modeToSymTable [idx].strType != NULL; idx++) { if ((statBufPtr->st_mode & S_IFMT) == modeToSymTable [idx].intType) return modeToSymTable [idx].strType; } return "unknown"; } /*----------------------------------------------------------------------------- * ReturnStatList -- * * Return file stat infomation as a keyed list. * * Parameters: * o interp (I) - The list is returned in result. * o ttyDev (O) - A boolean indicating if the device is associated with a * tty. * o statBufPtr (I) - Pointer to a buffer initialized by stat or fstat. *----------------------------------------------------------------------------- */ static void ReturnStatList (interp,ttyDev, statBufPtr) Tcl_Interp *interp; int ttyDev; struct stat *statBufPtr; { Tcl_Obj *keylPtr = TclX_NewKeyedListObj (); TclX_KeyedListSet (interp, keylPtr, "atime", Tcl_NewLongObj ((long) statBufPtr->st_atime)); TclX_KeyedListSet (interp, keylPtr, "ctime", Tcl_NewLongObj ((long) statBufPtr->st_ctime)); TclX_KeyedListSet (interp, keylPtr, "dev", Tcl_NewIntObj ((int) statBufPtr->st_dev)); TclX_KeyedListSet (interp, keylPtr, "gid", Tcl_NewIntObj ((int) statBufPtr->st_gid)); TclX_KeyedListSet (interp, keylPtr, "ino", Tcl_NewIntObj ((int) statBufPtr->st_ino)); TclX_KeyedListSet (interp, keylPtr, "mode", Tcl_NewIntObj ((int) statBufPtr->st_mode)); TclX_KeyedListSet (interp, keylPtr, "mtime", Tcl_NewLongObj ((long) statBufPtr->st_mtime)); TclX_KeyedListSet (interp, keylPtr, "nlink", Tcl_NewIntObj ((int) statBufPtr->st_nlink)); TclX_KeyedListSet (interp, keylPtr, "size", Tcl_NewLongObj ((long) statBufPtr->st_size)); TclX_KeyedListSet (interp, keylPtr, "uid", Tcl_NewIntObj ((int) statBufPtr->st_uid)); TclX_KeyedListSet (interp, keylPtr, "tty", Tcl_NewBooleanObj (ttyDev)); TclX_KeyedListSet (interp, keylPtr, "type", Tcl_NewStringObj (StrFileType (statBufPtr), -1)); Tcl_SetObjResult (interp, keylPtr); } /*----------------------------------------------------------------------------- * ReturnStatArray -- * * Return file stat infomation in an array. * * Parameters: * o interp (I) - Current interpreter, error return in result. * o ttyDev (O) - A boolean indicating if the device is associated with a * tty. * o statBufPtr (I) - Pointer to a buffer initialized by stat or fstat. * o arrayObj (I) - The the array to return the info in. * Returns: * TCL_OK or TCL_ERROR. *----------------------------------------------------------------------------- */ static int ReturnStatArray (interp, ttyDev, statBufPtr, arrayObj) Tcl_Interp *interp; int ttyDev; struct stat *statBufPtr; Tcl_Obj *arrayObj; { char *varName = Tcl_GetStringFromObj (arrayObj, NULL); if (Tcl_SetVar2Ex(interp, varName, "dev", Tcl_NewIntObj((int)statBufPtr->st_dev), TCL_LEAVE_ERR_MSG) == NULL) goto errorExit; if (Tcl_SetVar2Ex(interp, varName, "ino", Tcl_NewIntObj((int)statBufPtr->st_ino), TCL_LEAVE_ERR_MSG) == NULL) goto errorExit; if (Tcl_SetVar2Ex(interp, varName, "mode", Tcl_NewIntObj((int)statBufPtr->st_mode), TCL_LEAVE_ERR_MSG) == NULL) goto errorExit; if (Tcl_SetVar2Ex(interp, varName, "nlink", Tcl_NewIntObj((int)statBufPtr->st_nlink), TCL_LEAVE_ERR_MSG) == NULL) goto errorExit; if (Tcl_SetVar2Ex(interp, varName, "uid", Tcl_NewIntObj((int)statBufPtr->st_uid), TCL_LEAVE_ERR_MSG) == NULL) goto errorExit; if (Tcl_SetVar2Ex(interp, varName, "gid", Tcl_NewIntObj((int)statBufPtr->st_gid), TCL_LEAVE_ERR_MSG) == NULL) goto errorExit; if (Tcl_SetVar2Ex(interp, varName, "size", Tcl_NewLongObj((long)statBufPtr->st_size), TCL_LEAVE_ERR_MSG) == NULL) goto errorExit; if (Tcl_SetVar2Ex(interp, varName, "atime", Tcl_NewLongObj((long)statBufPtr->st_atime), TCL_LEAVE_ERR_MSG) == NULL) goto errorExit; if (Tcl_SetVar2Ex(interp, varName, "mtime", Tcl_NewLongObj((long)statBufPtr->st_mtime), TCL_LEAVE_ERR_MSG) == NULL) goto errorExit; if (Tcl_SetVar2Ex(interp, varName, "ctime", Tcl_NewLongObj((long)statBufPtr->st_ctime), TCL_LEAVE_ERR_MSG) == NULL) goto errorExit; if (Tcl_SetVar2Ex(interp, varName, "tty", Tcl_NewBooleanObj(ttyDev), TCL_LEAVE_ERR_MSG) == NULL) goto errorExit; if (Tcl_SetVar2Ex(interp, varName, "type", Tcl_NewStringObj(StrFileType(statBufPtr), -1), TCL_LEAVE_ERR_MSG) == NULL) goto errorExit; return TCL_OK; errorExit: return TCL_ERROR; } /*----------------------------------------------------------------------------- * ReturnStatItem -- * * Return a single file status item. * * Parameters: * o interp (I) - Item or error returned in result. * o channel (I) - Channel the file is assoicated with. * o ttyDev (O) - A boolean indicating if the device is associated with a * tty. * o statBufPtr (I) - Pointer to a buffer initialized by stat or fstat. * o itemName (I) - The name of the desired item. * Returns: * TCL_OK or TCL_ERROR. *----------------------------------------------------------------------------- */ static int ReturnStatItem (interp, channel, ttyDev, statBufPtr, itemName) Tcl_Interp *interp; Tcl_Channel channel; int ttyDev; struct stat *statBufPtr; char *itemName; { Tcl_Obj *objPtr; if (STREQU (itemName, "dev")) objPtr = Tcl_NewIntObj ((int) statBufPtr->st_dev); else if (STREQU (itemName, "ino")) objPtr = Tcl_NewIntObj ((int) statBufPtr->st_ino); else if (STREQU (itemName, "mode")) objPtr = Tcl_NewIntObj ((int) statBufPtr->st_mode); else if (STREQU (itemName, "nlink")) objPtr = Tcl_NewIntObj ((int) statBufPtr->st_nlink); else if (STREQU (itemName, "uid")) objPtr = Tcl_NewIntObj ((int) statBufPtr->st_uid); else if (STREQU (itemName, "gid")) objPtr = Tcl_NewIntObj ((int) statBufPtr->st_gid); else if (STREQU (itemName, "size")) objPtr = Tcl_NewLongObj ((long) statBufPtr->st_size); else if (STREQU (itemName, "atime")) objPtr = Tcl_NewLongObj ((long) statBufPtr->st_atime); else if (STREQU (itemName, "mtime")) objPtr = Tcl_NewLongObj ((long) statBufPtr->st_mtime); else if (STREQU (itemName, "ctime")) objPtr = Tcl_NewLongObj ((long) statBufPtr->st_ctime); else if (STREQU (itemName, "type")) objPtr = Tcl_NewStringObj (StrFileType (statBufPtr), -1); else if (STREQU (itemName, "tty")) objPtr = Tcl_NewBooleanObj (ttyDev); else if (STREQU (itemName, "remotehost")) { objPtr = TclXGetHostInfo (interp, channel, TRUE); if (objPtr == NULL) return TCL_ERROR; } else if (STREQU (itemName, "localhost")) { objPtr = TclXGetHostInfo (interp, channel, FALSE); if (objPtr == NULL) return TCL_ERROR; } else { TclX_AppendObjResult (interp, "Got \"", itemName, "\", expected one of ", "\"atime\", \"ctime\", \"dev\", \"gid\", ", "\"ino\", \"mode\", \"mtime\", \"nlink\", ", "\"size\", \"tty\", \"type\", \"uid\", ", "\"remotehost\", or \"localhost\"", (char *) NULL); return TCL_ERROR; } Tcl_SetObjResult (interp, objPtr); return TCL_OK; } /*----------------------------------------------------------------------------- * TclX_FstatObjCmd -- * Implements the fstat TCL command: * fstat fileId ?item?|?stat arrayvar? *----------------------------------------------------------------------------- */ static int TclX_FstatObjCmd (clientData, interp, objc, objv) ClientData clientData; Tcl_Interp *interp; int objc; Tcl_Obj *CONST objv[]; { Tcl_Channel channel; struct stat statBuf; int ttyDev; if ((objc < 2) || (objc > 4)) { return TclX_WrongArgs (interp, objv [0], "fileId ?item?|?stat arrayVar?"); } channel = TclX_GetOpenChannelObj (interp, objv [1], 0); if (channel == NULL) return TCL_ERROR; if (TclXOSFstat (interp, channel, &statBuf, &ttyDev)) { return TCL_ERROR; } /* * Return data in the requested format. */ if (objc >= 3) { char *itemName = Tcl_GetStringFromObj (objv [2], NULL); if (objc == 4) { if (!STREQU (itemName, "stat")) { TclX_AppendObjResult (interp, "expected item name of \"stat\" when ", "using array name", (char *) NULL); return TCL_ERROR; } return ReturnStatArray (interp, ttyDev, &statBuf, objv [3]); } else { return ReturnStatItem (interp, channel, ttyDev, &statBuf, itemName); } } ReturnStatList (interp, ttyDev, &statBuf); return TCL_OK; } /*----------------------------------------------------------------------------- * TclX_FstatInit -- * Initialize the fstat command. *----------------------------------------------------------------------------- */ void TclX_FstatInit (interp) Tcl_Interp *interp; { Tcl_CreateObjCommand (interp, "fstat", TclX_FstatObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc*) NULL); } tclx8.4-8.4.1.orig/generic/tclXkeylist.c0000644000000000000000000011364312046313170014661 0ustar /* * tclXkeylist.c -- * * Extended Tcl keyed list commands and interfaces. *----------------------------------------------------------------------------- * Copyright 1991-1999 Karl Lehenbauer and Mark Diekhans. * * Permission to use, copy, modify, and distribute this software and its * documentation for any purpose and without fee is hereby granted, provided * that the above copyright notice appear in all copies. Karl Lehenbauer and * Mark Diekhans make no representations about the suitability of this * software for any purpose. It is provided "as is" without express or * implied warranty. *----------------------------------------------------------------------------- * $Id: tclXkeylist.c,v 1.8 2005/11/21 18:54:13 hobbs Exp $ *----------------------------------------------------------------------------- */ #include "tclExtdInt.h" /* * Keyed lists are stored as arrays recursively defined objects. The data * portion of a keyed list entry is a Tcl_Obj which may be a keyed list object * or any other Tcl object. Since determine the structure of a keyed list is * lazy (you don't know if an element is data or another keyed list) until it * is accessed, the object can be transformed into a keyed list from a Tcl * string or list. */ /* * Adding a hash table over the entries allows for much faster Find * access to the keys (hash lookup instead of list search). This adds * a hash table to each keyed list object. That uses more memory, but * you can get an order of magnitude better performance with large * keyed list sets. Uncomment this line to not use the hash table. */ /* #define NO_KEYLIST_HASH_TABLE */ /* * An entry in a keyed list array. * * JH: There was the supposition that making the key an object would * be faster, but I tried that and didn't find it to be true. The * use of the layered hash table is a big win though. */ typedef struct { char *key; int keyLen; Tcl_Obj *valuePtr; } keylEntry_t; /* * Internal representation of a keyed list object. */ typedef struct { int arraySize; /* Current slots available in the array. */ int numEntries; /* Number of actual entries in the array. */ keylEntry_t *entries; /* Array of keyed list entries. */ #ifndef NO_KEYLIST_HASH_TABLE Tcl_HashTable *hashTbl; /* hash table mirror of the entries */ /* to improve speed */ #endif } keylIntObj_t; /* * Amount to increment array size by when it needs to grow. */ #define KEYEDLIST_ARRAY_INCR_SIZE 16 /* * Macro to duplicate a child entry of a keyed list if it is share by more * than the parent. * NO_KEYLIST_HASH_TABLE: We don't duplicate the hash table, so ensure * that consistency checks allow for portions where not all entries are * in the hash table. */ #define DupSharedKeyListChild(keylIntPtr, idx) \ if (Tcl_IsShared(keylIntPtr->entries [idx].valuePtr)) { \ keylIntPtr->entries [idx].valuePtr = \ Tcl_DuplicateObj (keylIntPtr->entries [idx].valuePtr); \ Tcl_IncrRefCount(keylIntPtr->entries [idx].valuePtr); \ } /* * Macros to validate an keyed list object or internal representation */ #ifdef TCLX_DEBUG # define KEYL_OBJ_ASSERT(keylAPtr) {\ TclX_Assert (keylAPtr->typePtr == &keyedListType); \ ValidateKeyedList (keylAIntPtr); \ } # define KEYL_REP_ASSERT(keylAIntPtr) \ ValidateKeyedList (keylAIntPtr) #else # define KEYL_REP_ASSERT(keylAIntPtr) #endif /* * Prototypes of internal functions. */ #ifdef TCLX_DEBUG static void ValidateKeyedList _ANSI_ARGS_((keylIntObj_t *keylIntPtr)); #endif static int ValidateKey _ANSI_ARGS_((Tcl_Interp *interp, char *key, int keyLen)); static keylIntObj_t * AllocKeyedListIntRep _ANSI_ARGS_((void)); static void FreeKeyedListData _ANSI_ARGS_((keylIntObj_t *keylIntPtr)); static void EnsureKeyedListSpace _ANSI_ARGS_((keylIntObj_t *keylIntPtr, int newNumEntries)); static void DeleteKeyedListEntry _ANSI_ARGS_((keylIntObj_t *keylIntPtr, int entryIdx)); static int FindKeyedListEntry _ANSI_ARGS_((keylIntObj_t *keylIntPtr, char *key, int *keyLenPtr, char **nextSubKeyPtr)); static void DupKeyedListInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr, Tcl_Obj *copyPtr)); static void FreeKeyedListInternalRep _ANSI_ARGS_((Tcl_Obj *keylPtr)); static int SetKeyedListFromAny _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr)); static void UpdateStringOfKeyedList _ANSI_ARGS_((Tcl_Obj *keylPtr)); static int TclX_KeylgetObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int TclX_KeylsetObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int TclX_KeyldelObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int TclX_KeylkeysObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); /* * Type definition. */ static Tcl_ObjType keyedListType = { "keyedList", /* name */ FreeKeyedListInternalRep, /* freeIntRepProc */ DupKeyedListInternalRep, /* dupIntRepProc */ UpdateStringOfKeyedList, /* updateStringProc */ SetKeyedListFromAny /* setFromAnyProc */ }; /*----------------------------------------------------------------------------- * ValidateKeyedList -- * Validate a keyed list (only when TCLX_DEBUG is enabled). * Parameters: * o keylIntPtr - Keyed list internal representation. *----------------------------------------------------------------------------- */ #ifdef TCLX_DEBUG static void ValidateKeyedList (keylIntPtr) keylIntObj_t *keylIntPtr; { int idx; TclX_Assert (keylIntPtr->arraySize >= keylIntPtr->numEntries); TclX_Assert (keylIntPtr->arraySize >= 0); TclX_Assert (keylIntPtr->numEntries >= 0); TclX_Assert ((keylIntPtr->arraySize > 0) ? (keylIntPtr->entries != NULL) : TRUE); TclX_Assert ((keylIntPtr->numEntries > 0) ? (keylIntPtr->entries != NULL) : TRUE); for (idx = 0; idx < keylIntPtr->numEntries; idx++) { keylEntry_t *entryPtr = &(keylIntPtr->entries [idx]); TclX_Assert (entryPtr->key != NULL); TclX_Assert (entryPtr->valuePtr->refCount >= 1); if (entryPtr->valuePtr->typePtr == &keyedListType) { ValidateKeyedList (entryPtr->valuePtr->internalRep.otherValuePtr); } } } #endif /*----------------------------------------------------------------------------- * ValidateKey -- * Check that a key or keypath string is a valid value. * * Parameters: * o interp - Used to return error messages. * o key - Key string to check. * o keyLen - Length of the string, used to check for binary data. * Returns: * TCL_OK or TCL_ERROR. *----------------------------------------------------------------------------- */ static int ValidateKey (interp, key, keyLen) Tcl_Interp *interp; char *key; int keyLen; { if (strlen (key) != (size_t) keyLen) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "keyed list key may not be a binary string", (char *) NULL); return TCL_ERROR; } if (keyLen == 0) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "keyed list key may not be an empty string", (char *) NULL); return TCL_ERROR; } return TCL_OK; } /*----------------------------------------------------------------------------- * AllocKeyedListIntRep -- * Allocate an and initialize the keyed list internal representation. * * Returns: * A pointer to the keyed list internal structure. *----------------------------------------------------------------------------- */ static keylIntObj_t * AllocKeyedListIntRep () { keylIntObj_t *keylIntPtr; keylIntPtr = (keylIntObj_t *) ckalloc (sizeof (keylIntObj_t)); memset(keylIntPtr, 0, sizeof (keylIntObj_t)); #ifndef NO_KEYLIST_HASH_TABLE keylIntPtr->hashTbl = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(keylIntPtr->hashTbl, TCL_STRING_KEYS); #endif return keylIntPtr; } /*----------------------------------------------------------------------------- * FreeKeyedListData -- * Free the internal representation of a keyed list. * * Parameters: * o keylIntPtr - Keyed list internal structure to free. *----------------------------------------------------------------------------- */ static void FreeKeyedListData (keylIntPtr) keylIntObj_t *keylIntPtr; { int idx; for (idx = 0; idx < keylIntPtr->numEntries ; idx++) { ckfree (keylIntPtr->entries [idx].key); Tcl_DecrRefCount(keylIntPtr->entries [idx].valuePtr); } if (keylIntPtr->entries != NULL) ckfree ((VOID*) keylIntPtr->entries); #ifndef NO_KEYLIST_HASH_TABLE if (keylIntPtr->hashTbl != NULL) { Tcl_DeleteHashTable(keylIntPtr->hashTbl); ckfree((char *) (keylIntPtr->hashTbl)); } #endif ckfree ((VOID*) keylIntPtr); } /*----------------------------------------------------------------------------- * EnsureKeyedListSpace -- * Ensure there is enough room in a keyed list array for a certain number * of entries, expanding if necessary. * * Parameters: * o keylIntPtr - Keyed list internal representation. * o newNumEntries - The number of entries that are going to be added to * the keyed list. *----------------------------------------------------------------------------- */ static void EnsureKeyedListSpace (keylIntPtr, newNumEntries) keylIntObj_t *keylIntPtr; int newNumEntries; { KEYL_REP_ASSERT (keylIntPtr); if ((keylIntPtr->arraySize - keylIntPtr->numEntries) < newNumEntries) { int newSize = keylIntPtr->arraySize + newNumEntries + KEYEDLIST_ARRAY_INCR_SIZE; if (keylIntPtr->entries == NULL) { keylIntPtr->entries = (keylEntry_t *) ckalloc (newSize * sizeof (keylEntry_t)); } else { keylIntPtr->entries = (keylEntry_t *) ckrealloc ((VOID *) keylIntPtr->entries, newSize * sizeof (keylEntry_t)); } keylIntPtr->arraySize = newSize; } KEYL_REP_ASSERT (keylIntPtr); } /*----------------------------------------------------------------------------- * DeleteKeyedListEntry -- * Delete an entry from a keyed list. * * Parameters: * o keylIntPtr - Keyed list internal representation. * o entryIdx - Index of entry to delete. *----------------------------------------------------------------------------- */ static void DeleteKeyedListEntry (keylIntPtr, entryIdx) keylIntObj_t *keylIntPtr; int entryIdx; { int idx; #ifndef NO_KEYLIST_HASH_TABLE if (keylIntPtr->hashTbl != NULL) { Tcl_HashEntry *entryPtr; Tcl_HashSearch search; int nidx; entryPtr = Tcl_FindHashEntry(keylIntPtr->hashTbl, keylIntPtr->entries [entryIdx].key); if (entryPtr != NULL) { Tcl_DeleteHashEntry(entryPtr); } /* * In order to maintain consistency, we have to iterate over * the entire hash table to find and decr relevant idxs. * We have to do this even if the previous index was not found * in the hash table, as Dup'ing doesn't dup the hash tables. */ for (entryPtr = Tcl_FirstHashEntry(keylIntPtr->hashTbl, &search); entryPtr != NULL; entryPtr = Tcl_NextHashEntry(&search)) { nidx = (int) Tcl_GetHashValue(entryPtr); if (nidx > entryIdx) { Tcl_SetHashValue(entryPtr, (ClientData) (nidx - 1)); } } } #endif ckfree (keylIntPtr->entries [entryIdx].key); Tcl_DecrRefCount(keylIntPtr->entries [entryIdx].valuePtr); for (idx = entryIdx; idx < keylIntPtr->numEntries - 1; idx++) keylIntPtr->entries [idx] = keylIntPtr->entries [idx + 1]; keylIntPtr->numEntries--; KEYL_REP_ASSERT (keylIntPtr); } /*----------------------------------------------------------------------------- * FindKeyedListEntry -- * Find an entry in keyed list. * * Parameters: * o keylIntPtr - Keyed list internal representation. * o key - Name of key to search for. * o keyLenPtr - In not NULL, the length of the key for this * level is returned here. This excludes subkeys and the `.' delimiters. * o nextSubKeyPtr - If not NULL, the start of the name of the next * sub-key within key is returned. * Returns: * Index of the entry or -1 if not found. *----------------------------------------------------------------------------- */ static int FindKeyedListEntry (keylIntPtr, key, keyLenPtr, nextSubKeyPtr) keylIntObj_t *keylIntPtr; char *key; int *keyLenPtr; char **nextSubKeyPtr; { char *keySeparPtr; int keyLen, findIdx = -1; keySeparPtr = strchr (key, '.'); if (keySeparPtr != NULL) { keyLen = keySeparPtr - key; } else { keyLen = strlen (key); } #ifndef NO_KEYLIST_HASH_TABLE if (keylIntPtr->hashTbl != NULL) { Tcl_HashEntry *entryPtr; char tmp = key[keyLen]; if (keySeparPtr != NULL) { /* * A few extra guards in setting this, as if we are passed * a const char, this can crash. */ key[keyLen] = '\0'; } entryPtr = Tcl_FindHashEntry(keylIntPtr->hashTbl, key); if (entryPtr != NULL) { findIdx = (int) Tcl_GetHashValue(entryPtr); } if (keySeparPtr != NULL) { key[keyLen] = tmp; } } #endif if (findIdx == -1) { for (findIdx = 0; findIdx < keylIntPtr->numEntries; findIdx++) { if (keylIntPtr->entries [findIdx].keyLen == keyLen && STRNEQU(keylIntPtr->entries [findIdx].key, key, keyLen)) { break; } } } if (nextSubKeyPtr != NULL) { if (keySeparPtr == NULL) { *nextSubKeyPtr = NULL; } else { *nextSubKeyPtr = keySeparPtr + 1; } } if (keyLenPtr != NULL) { *keyLenPtr = keyLen; } if (findIdx >= keylIntPtr->numEntries) { return -1; } return findIdx; } /*----------------------------------------------------------------------------- * FreeKeyedListInternalRep -- * Free the internal representation of a keyed list. * * Parameters: * o keylPtr - Keyed list object being deleted. *----------------------------------------------------------------------------- */ static void FreeKeyedListInternalRep (keylPtr) Tcl_Obj *keylPtr; { FreeKeyedListData ((keylIntObj_t *) keylPtr->internalRep.otherValuePtr); } /*----------------------------------------------------------------------------- * DupKeyedListInternalRep -- * Duplicate the internal representation of a keyed list. * * Parameters: * o srcPtr - Keyed list object to copy. * o copyPtr - Target object to copy internal representation to. *----------------------------------------------------------------------------- */ static void DupKeyedListInternalRep (srcPtr, copyPtr) Tcl_Obj *srcPtr; Tcl_Obj *copyPtr; { keylIntObj_t *srcIntPtr = (keylIntObj_t *) srcPtr->internalRep.otherValuePtr; keylIntObj_t *copyIntPtr; int idx; KEYL_REP_ASSERT (srcIntPtr); copyIntPtr = (keylIntObj_t *) ckalloc (sizeof (keylIntObj_t)); copyIntPtr->arraySize = srcIntPtr->arraySize; copyIntPtr->numEntries = srcIntPtr->numEntries; copyIntPtr->entries = (keylEntry_t *) ckalloc (copyIntPtr->arraySize * sizeof (keylEntry_t)); #ifndef NO_KEYLIST_HASH_TABLE #if 0 copyIntPtr->hashTbl = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(copyIntPtr->hashTbl, TCL_STRING_KEYS); #else /* * NO_KEYLIST_HASH_TABLE: We don't duplicate the hash table, so ensure * that consistency checks allow for portions where not all entries are * in the hash table. */ copyIntPtr->hashTbl = NULL; #endif #endif for (idx = 0; idx < srcIntPtr->numEntries ; idx++) { copyIntPtr->entries [idx].key = ckstrdup (srcIntPtr->entries [idx].key); copyIntPtr->entries [idx].keyLen = srcIntPtr->entries [idx].keyLen; copyIntPtr->entries [idx].valuePtr = Tcl_DuplicateObj(srcIntPtr->entries [idx].valuePtr); Tcl_IncrRefCount(copyIntPtr->entries [idx].valuePtr); #ifndef NO_KEYLIST_HASH_TABLE /* * If we dup the hash table as well and do other better tracking * of all access, then we could remove the entries list. */ #endif } copyPtr->internalRep.otherValuePtr = (VOID *) copyIntPtr; copyPtr->typePtr = &keyedListType; KEYL_REP_ASSERT (copyIntPtr); } /*----------------------------------------------------------------------------- * SetKeyedListFromAny -- * Convert an object to a keyed list from its string representation. Only * the first level is converted, as there is no way of knowing how far down * the keyed list recurses until lower levels are accessed. * * Parameters: * o objPtr - Object to convert to a keyed list. *----------------------------------------------------------------------------- */ static int SetKeyedListFromAny (interp, objPtr) Tcl_Interp *interp; Tcl_Obj *objPtr; { keylIntObj_t *keylIntPtr; keylEntry_t *keyEntryPtr; char *key; int keyLen, idx, objc, subObjc; Tcl_Obj **objv, **subObjv; #ifndef NO_KEYLIST_HASH_TABLE int dummy; Tcl_HashEntry *entryPtr; #endif if (Tcl_ListObjGetElements (interp, objPtr, &objc, &objv) != TCL_OK) { return TCL_ERROR; } keylIntPtr = AllocKeyedListIntRep(); EnsureKeyedListSpace(keylIntPtr, objc); for (idx = 0; idx < objc; idx++) { if ((Tcl_ListObjGetElements(interp, objv[idx], &subObjc, &subObjv) != TCL_OK) || (subObjc != 2)) { Tcl_ResetResult(interp); Tcl_AppendStringsToObj(Tcl_GetObjResult (interp), "keyed list entry must be a valid, 2 element list, got \"", Tcl_GetString(objv[idx]), "\"", (char *) NULL); FreeKeyedListData(keylIntPtr); return TCL_ERROR; } key = Tcl_GetStringFromObj(subObjv[0], &keyLen); if (ValidateKey(interp, key, keyLen) == TCL_ERROR) { FreeKeyedListData (keylIntPtr); return TCL_ERROR; } /* * When setting from a random list/string, we cannot allow * keys to have embedded '.' path separators */ if ((strchr(key, '.') != NULL)) { Tcl_AppendStringsToObj (Tcl_GetObjResult (interp), "keyed list key may not contain a \".\"; ", "it is used as a separator in key paths", (char *) NULL); FreeKeyedListData (keylIntPtr); return TCL_ERROR; } keyEntryPtr = &(keylIntPtr->entries[idx]); keyEntryPtr->key = ckstrdup(key); keyEntryPtr->keyLen = keyLen; keyEntryPtr->valuePtr = Tcl_DuplicateObj(subObjv[1]); Tcl_IncrRefCount(keyEntryPtr->valuePtr); #ifndef NO_KEYLIST_HASH_TABLE entryPtr = Tcl_CreateHashEntry(keylIntPtr->hashTbl, keyEntryPtr->key, &dummy); Tcl_SetHashValue(entryPtr, (ClientData) idx); #endif keylIntPtr->numEntries++; } if ((objPtr->typePtr != NULL) && (objPtr->typePtr->freeIntRepProc != NULL)) { (*objPtr->typePtr->freeIntRepProc) (objPtr); } objPtr->internalRep.otherValuePtr = (VOID *) keylIntPtr; objPtr->typePtr = &keyedListType; KEYL_REP_ASSERT (keylIntPtr); return TCL_OK; } /*----------------------------------------------------------------------------- * UpdateStringOfKeyedList -- * Update the string representation of a keyed list. * * Parameters: * o objPtr - Object to convert to a keyed list. *----------------------------------------------------------------------------- */ static void UpdateStringOfKeyedList (keylPtr) Tcl_Obj *keylPtr; { #define UPDATE_STATIC_SIZE 32 int idx, strLen; Tcl_Obj **listObjv, *entryObjv [2], *tmpListObj; Tcl_Obj *staticListObjv [UPDATE_STATIC_SIZE]; char *listStr; keylIntObj_t *keylIntPtr = (keylIntObj_t *) keylPtr->internalRep.otherValuePtr; /* * Conversion to strings is done via list objects to support binary data. */ if (keylIntPtr->numEntries > UPDATE_STATIC_SIZE) { listObjv = (Tcl_Obj **) ckalloc (keylIntPtr->numEntries * sizeof (Tcl_Obj *)); } else { listObjv = staticListObjv; } /* * Convert each keyed list entry to a two element list object. No * need to incr/decr ref counts, the list objects will take care of that. * FIX: Keeping key as string object will speed this up. */ for (idx = 0; idx < keylIntPtr->numEntries; idx++) { entryObjv [0] = Tcl_NewStringObj (keylIntPtr->entries [idx].key, keylIntPtr->entries [idx].keyLen); entryObjv [1] = keylIntPtr->entries [idx].valuePtr; listObjv [idx] = Tcl_NewListObj (2, entryObjv); } tmpListObj = Tcl_NewListObj (keylIntPtr->numEntries, listObjv); Tcl_IncrRefCount(tmpListObj); listStr = Tcl_GetStringFromObj (tmpListObj, &strLen); keylPtr->bytes = ckbinstrdup (listStr, strLen); keylPtr->length = strLen; Tcl_DecrRefCount(tmpListObj); if (listObjv != staticListObjv) ckfree ((VOID*) listObjv); } /*----------------------------------------------------------------------------- * TclX_NewKeyedListObj -- * Create and initialize a new keyed list object. * * Returns: * A pointer to the object. *----------------------------------------------------------------------------- */ Tcl_Obj * TclX_NewKeyedListObj () { Tcl_Obj *keylPtr = Tcl_NewObj (); keylIntObj_t *keylIntPtr = AllocKeyedListIntRep (); keylPtr->internalRep.otherValuePtr = (VOID *) keylIntPtr; keylPtr->typePtr = &keyedListType; return keylPtr; } /*----------------------------------------------------------------------------- * TclX_KeyedListGet -- * Retrieve a key value from a keyed list. * * Parameters: * o interp - Error message will be return in result if there is an error. * o keylPtr - Keyed list object to get key from. * o key - The name of the key to extract. Will recusively process sub-keys * seperated by `.'. * o valueObjPtrPtr - If the key is found, a pointer to the key object * is returned here. NULL is returned if the key is not present. * Returns: * o TCL_OK - If the key value was returned. * o TCL_BREAK - If the key was not found. * o TCL_ERROR - If an error occured. *----------------------------------------------------------------------------- */ int TclX_KeyedListGet (interp, keylPtr, key, valuePtrPtr) Tcl_Interp *interp; Tcl_Obj *keylPtr; char *key; Tcl_Obj **valuePtrPtr; { keylIntObj_t *keylIntPtr; char *nextSubKey; int findIdx; while (1) { if (Tcl_ConvertToType (interp, keylPtr, &keyedListType) != TCL_OK) return TCL_ERROR; keylIntPtr = (keylIntObj_t *) keylPtr->internalRep.otherValuePtr; KEYL_REP_ASSERT (keylIntPtr); findIdx = FindKeyedListEntry(keylIntPtr, key, NULL, &nextSubKey); /* * If not found, return status. */ if (findIdx < 0) { *valuePtrPtr = NULL; return TCL_BREAK; } /* * If we are at the last subkey, return the entry, otherwise recurse * down looking for the entry. */ if (nextSubKey == NULL) { *valuePtrPtr = keylIntPtr->entries [findIdx].valuePtr; return TCL_OK; } else { keylPtr = keylIntPtr->entries [findIdx].valuePtr; key = nextSubKey; } } } /*----------------------------------------------------------------------------- * TclX_KeyedListSet -- * Set a key value in keyed list object. * * Parameters: * o interp - Error message will be return in result object. * o keylPtr - Keyed list object to update. * o key - The name of the key to extract. Will recursively process * sub-key seperated by `.'. * o valueObjPtr - The value to set for the key. * Returns: * TCL_OK or TCL_ERROR. *----------------------------------------------------------------------------- */ int TclX_KeyedListSet (interp, keylPtr, key, valuePtr) Tcl_Interp *interp; Tcl_Obj *keylPtr; char *key; Tcl_Obj *valuePtr; { keylIntObj_t *keylIntPtr; keylEntry_t *keyEntryPtr; char *nextSubKey; int findIdx, keyLen, status = TCL_OK; Tcl_Obj *newKeylPtr; while (1) { if (Tcl_ConvertToType (interp, keylPtr, &keyedListType) != TCL_OK) return TCL_ERROR; keylIntPtr = (keylIntObj_t *) keylPtr->internalRep.otherValuePtr; KEYL_REP_ASSERT (keylIntPtr); findIdx = FindKeyedListEntry (keylIntPtr, key, &keyLen, &nextSubKey); /* * If we are at the last subkey, either update or add an entry. */ if (nextSubKey == NULL) { #ifndef NO_KEYLIST_HASH_TABLE int dummy; Tcl_HashEntry *entryPtr; #endif if (findIdx < 0) { EnsureKeyedListSpace (keylIntPtr, 1); findIdx = keylIntPtr->numEntries++; } else { ckfree (keylIntPtr->entries [findIdx].key); Tcl_DecrRefCount(keylIntPtr->entries [findIdx].valuePtr); } keyEntryPtr = &(keylIntPtr->entries[findIdx]); keyEntryPtr->key = (char *) ckalloc (keyLen + 1); memcpy(keyEntryPtr->key, key, keyLen); keyEntryPtr->key[keyLen] = '\0'; keyEntryPtr->keyLen = keyLen; keyEntryPtr->valuePtr = valuePtr; Tcl_IncrRefCount(valuePtr); #ifndef NO_KEYLIST_HASH_TABLE if (keylIntPtr->hashTbl == NULL) { keylIntPtr->hashTbl = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(keylIntPtr->hashTbl, TCL_STRING_KEYS); } entryPtr = Tcl_CreateHashEntry(keylIntPtr->hashTbl, keyEntryPtr->key, &dummy); Tcl_SetHashValue(entryPtr, (ClientData) findIdx); #endif Tcl_InvalidateStringRep (keylPtr); KEYL_REP_ASSERT (keylIntPtr); return TCL_OK; } /* * If we are not at the last subkey, recurse down, creating new * entries if neccessary. If this level key was not found, it * means we must build new subtree. Don't insert the new tree until we * come back without error. */ if (findIdx >= 0) { DupSharedKeyListChild (keylIntPtr, findIdx); status = TclX_KeyedListSet (interp, keylIntPtr->entries [findIdx].valuePtr, nextSubKey, valuePtr); if (status == TCL_OK) { Tcl_InvalidateStringRep (keylPtr); } } else { #ifndef NO_KEYLIST_HASH_TABLE int dummy; Tcl_HashEntry *entryPtr; #endif newKeylPtr = TclX_NewKeyedListObj (); Tcl_IncrRefCount(newKeylPtr); if (TclX_KeyedListSet (interp, newKeylPtr, nextSubKey, valuePtr) != TCL_OK) { Tcl_DecrRefCount(newKeylPtr); return TCL_ERROR; } EnsureKeyedListSpace (keylIntPtr, 1); findIdx = keylIntPtr->numEntries++; keyEntryPtr = &(keylIntPtr->entries[findIdx]); keyEntryPtr->key = (char *) ckalloc (keyLen + 1); memcpy(keyEntryPtr->key, key, keyLen); keyEntryPtr->key[keyLen] = '\0'; keyEntryPtr->keyLen = keyLen; keyEntryPtr->valuePtr = newKeylPtr; #ifndef NO_KEYLIST_HASH_TABLE if (keylIntPtr->hashTbl == NULL) { keylIntPtr->hashTbl = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(keylIntPtr->hashTbl, TCL_STRING_KEYS); } entryPtr = Tcl_CreateHashEntry(keylIntPtr->hashTbl, keyEntryPtr->key, &dummy); Tcl_SetHashValue(entryPtr, (ClientData) findIdx); #endif Tcl_InvalidateStringRep (keylPtr); } KEYL_REP_ASSERT (keylIntPtr); return status; } } /*----------------------------------------------------------------------------- * TclX_KeyedListDelete -- * Delete a key value from keyed list. * * Parameters: * o interp - Error message will be return in result if there is an error. * o keylPtr - Keyed list object to update. * o key - The name of the key to extract. Will recusively process * sub-key seperated by `.'. * Returns: * o TCL_OK - If the key was deleted. * o TCL_BREAK - If the key was not found. * o TCL_ERROR - If an error occured. *----------------------------------------------------------------------------- */ int TclX_KeyedListDelete (interp, keylPtr, key) Tcl_Interp *interp; Tcl_Obj *keylPtr; char *key; { keylIntObj_t *keylIntPtr, *subKeylIntPtr; char *nextSubKey; int findIdx, status; if (Tcl_ConvertToType (interp, keylPtr, &keyedListType) != TCL_OK) return TCL_ERROR; keylIntPtr = (keylIntObj_t *) keylPtr->internalRep.otherValuePtr; findIdx = FindKeyedListEntry (keylIntPtr, key, NULL, &nextSubKey); /* * If not found, return status. */ if (findIdx < 0) { KEYL_REP_ASSERT (keylIntPtr); return TCL_BREAK; } /* * If we are at the last subkey, delete the entry. */ if (nextSubKey == NULL) { DeleteKeyedListEntry (keylIntPtr, findIdx); Tcl_InvalidateStringRep (keylPtr); KEYL_REP_ASSERT (keylIntPtr); return TCL_OK; } /* * If we are not at the last subkey, recurse down. If the entry is * deleted and the sub-keyed list is empty, delete it as well. Must * invalidate string, as it caches all representations below it. */ DupSharedKeyListChild (keylIntPtr, findIdx); status = TclX_KeyedListDelete (interp, keylIntPtr->entries [findIdx].valuePtr, nextSubKey); if (status == TCL_OK) { subKeylIntPtr = (keylIntObj_t *) keylIntPtr->entries [findIdx].valuePtr->internalRep.otherValuePtr; if (subKeylIntPtr->numEntries == 0) { DeleteKeyedListEntry (keylIntPtr, findIdx); } Tcl_InvalidateStringRep (keylPtr); } KEYL_REP_ASSERT (keylIntPtr); return status; } /*----------------------------------------------------------------------------- * TclX_KeyedListGetKeys -- * Retrieve a list of keyed list keys. * * Parameters: * o interp - Error message will be return in result if there is an error. * o keylPtr - Keyed list object to get key from. * o key - The name of the key to get the sub keys for. NULL or empty * to retrieve all top level keys. * o listObjPtrPtr - List object is returned here with key as values. * Returns: * o TCL_OK - If the zero or more key where returned. * o TCL_BREAK - If the key was not found. * o TCL_ERROR - If an error occured. *----------------------------------------------------------------------------- */ int TclX_KeyedListGetKeys (interp, keylPtr, key, listObjPtrPtr) Tcl_Interp *interp; Tcl_Obj *keylPtr; char *key; Tcl_Obj **listObjPtrPtr; { keylIntObj_t *keylIntPtr; Tcl_Obj *listObjPtr; char *nextSubKey; int idx, findIdx; if (Tcl_ConvertToType (interp, keylPtr, &keyedListType) != TCL_OK) return TCL_ERROR; keylIntPtr = (keylIntObj_t *) keylPtr->internalRep.otherValuePtr; /* * If key is not NULL or empty, then recurse down until we go past * the end of all of the elements of the key. */ if ((key != NULL) && (key [0] != '\0')) { findIdx = FindKeyedListEntry (keylIntPtr, key, NULL, &nextSubKey); if (findIdx < 0) { TclX_Assert (keylIntPtr->arraySize >= keylIntPtr->numEntries); return TCL_BREAK; } TclX_Assert (keylIntPtr->arraySize >= keylIntPtr->numEntries); return TclX_KeyedListGetKeys (interp, keylIntPtr->entries [findIdx].valuePtr, nextSubKey, listObjPtrPtr); } /* * Reached the end of the full key, return all keys at this level. */ listObjPtr = Tcl_NewObj(); for (idx = 0; idx < keylIntPtr->numEntries; idx++) { Tcl_ListObjAppendElement(interp, listObjPtr, Tcl_NewStringObj(keylIntPtr->entries[idx].key, keylIntPtr->entries[idx].keyLen)); } *listObjPtrPtr = listObjPtr; TclX_Assert (keylIntPtr->arraySize >= keylIntPtr->numEntries); return TCL_OK; } /*----------------------------------------------------------------------------- * Tcl_KeylgetObjCmd -- * Implements the TCL keylget command: * keylget listvar ?key? ?retvar | {}? *----------------------------------------------------------------------------- */ static int TclX_KeylgetObjCmd (clientData, interp, objc, objv) ClientData clientData; Tcl_Interp *interp; int objc; Tcl_Obj *CONST objv[]; { Tcl_Obj *keylPtr, *valuePtr; char *key; int keyLen, status; if ((objc < 2) || (objc > 4)) { return TclX_WrongArgs (interp, objv [0], "listvar ?key? ?retvar | {}?"); } /* * Handle request for list of keys, use keylkeys command. */ if (objc == 2) return TclX_KeylkeysObjCmd (clientData, interp, objc, objv); keylPtr = Tcl_ObjGetVar2(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG); if (keylPtr == NULL) { return TCL_ERROR; } /* * Handle retrieving a value for a specified key. */ key = Tcl_GetStringFromObj (objv [2], &keyLen); if (ValidateKey(interp, key, keyLen) == TCL_ERROR) { return TCL_ERROR; } status = TclX_KeyedListGet (interp, keylPtr, key, &valuePtr); if (status == TCL_ERROR) return TCL_ERROR; /* * Handle key not found. */ if (status == TCL_BREAK) { if (objc == 3) { TclX_AppendObjResult (interp, "key \"", key, "\" not found in keyed list", (char *) NULL); return TCL_ERROR; } else { Tcl_SetBooleanObj (Tcl_GetObjResult (interp), FALSE); return TCL_OK; } } /* * No variable specified, so return value in the result. */ if (objc == 3) { Tcl_SetObjResult (interp, valuePtr); return TCL_OK; } /* * Variable (or empty variable name) specified. */ if (!TclX_IsNullObj(objv [3]) && (Tcl_ObjSetVar2(interp, objv [3], NULL, valuePtr, TCL_LEAVE_ERR_MSG) == NULL)) { return TCL_ERROR; } Tcl_SetBooleanObj (Tcl_GetObjResult (interp), TRUE); return TCL_OK; } /*----------------------------------------------------------------------------- * Tcl_KeylsetObjCmd -- * Implements the TCL keylset command: * keylset listvar key value ?key value...? *----------------------------------------------------------------------------- */ static int TclX_KeylsetObjCmd (clientData, interp, objc, objv) ClientData clientData; Tcl_Interp *interp; int objc; Tcl_Obj *CONST objv[]; { Tcl_Obj *keylVarPtr, *newVarObj; char *key; int idx, keyLen, result = TCL_OK; if ((objc < 4) || ((objc % 2) != 0)) { return TclX_WrongArgs (interp, objv [0], "listvar key value ?key value...?"); } /* * Get the variable that we are going to update. If the var doesn't exist, * create it. If it is shared by more than being a variable, duplicated * it. */ keylVarPtr = Tcl_ObjGetVar2(interp, objv[1], NULL, 0); if (keylVarPtr == NULL) { newVarObj = keylVarPtr = TclX_NewKeyedListObj(); Tcl_IncrRefCount(newVarObj); } else if (Tcl_IsShared(keylVarPtr)) { newVarObj = keylVarPtr = Tcl_DuplicateObj(keylVarPtr); Tcl_IncrRefCount(newVarObj); } else { newVarObj = NULL; } for (idx = 2; idx < objc; idx += 2) { key = Tcl_GetStringFromObj (objv [idx], &keyLen); if ((ValidateKey(interp, key, keyLen) == TCL_ERROR) || (TclX_KeyedListSet (interp, keylVarPtr, key, objv [idx+1]) != TCL_OK)) { result = TCL_ERROR; break; } } if ((result == TCL_OK) && (Tcl_ObjSetVar2(interp, objv[1], NULL, keylVarPtr, TCL_LEAVE_ERR_MSG) == NULL)) { result = TCL_ERROR; } if (newVarObj != NULL) { Tcl_DecrRefCount(newVarObj); } return result; } /*----------------------------------------------------------------------------- * Tcl_KeyldelObjCmd -- * Implements the TCL keyldel command: * keyldel listvar key ?key ...? *---------------------------------------------------------------------------- */ static int TclX_KeyldelObjCmd (clientData, interp, objc, objv) ClientData clientData; Tcl_Interp *interp; int objc; Tcl_Obj *CONST objv[]; { Tcl_Obj *keylVarPtr, *keylPtr; char *key; int idx, keyLen, status; if (objc < 3) { return TclX_WrongArgs (interp, objv [0], "listvar key ?key ...?"); } /* * Get the variable that we are going to update. If it is shared by more * than being a variable, duplicated it. */ keylVarPtr = Tcl_ObjGetVar2(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG); if (keylVarPtr == NULL) { return TCL_ERROR; } if (Tcl_IsShared (keylVarPtr)) { keylPtr = Tcl_DuplicateObj (keylVarPtr); keylVarPtr = Tcl_ObjSetVar2(interp, objv[1], NULL, keylPtr, TCL_LEAVE_ERR_MSG); if (keylVarPtr == NULL) { Tcl_DecrRefCount(keylPtr); return TCL_ERROR; } if (keylVarPtr != keylPtr) Tcl_DecrRefCount(keylPtr); } keylPtr = keylVarPtr; for (idx = 2; idx < objc; idx++) { key = Tcl_GetStringFromObj (objv [idx], &keyLen); if (ValidateKey(interp, key, keyLen) == TCL_ERROR) { return TCL_ERROR; } status = TclX_KeyedListDelete (interp, keylPtr, key); switch (status) { case TCL_BREAK: TclX_AppendObjResult (interp, "key not found: \"", key, "\"", (char *) NULL); return TCL_ERROR; case TCL_ERROR: return TCL_ERROR; } } return TCL_OK; } /*----------------------------------------------------------------------------- * Tcl_KeylkeysObjCmd -- * Implements the TCL keylkeys command: * keylkeys listvar ?key? *----------------------------------------------------------------------------- */ static int TclX_KeylkeysObjCmd (clientData, interp, objc, objv) ClientData clientData; Tcl_Interp *interp; int objc; Tcl_Obj *CONST objv[]; { Tcl_Obj *keylPtr, *listObjPtr; char *key; int keyLen, status; if ((objc < 2) || (objc > 3)) { return TclX_WrongArgs (interp, objv [0], "listvar ?key?"); } keylPtr = Tcl_ObjGetVar2(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG); if (keylPtr == NULL) { return TCL_ERROR; } /* * If key argument is not specified, then objv [2] is NULL or empty, * meaning get top level keys. */ if (objc < 3) { key = NULL; } else { key = Tcl_GetStringFromObj (objv [2], &keyLen); if (ValidateKey(interp, key, keyLen) == TCL_ERROR) { return TCL_ERROR; } } status = TclX_KeyedListGetKeys (interp, keylPtr, key, &listObjPtr); switch (status) { case TCL_BREAK: TclX_AppendObjResult (interp, "key not found: \"", key, "\"", (char *) NULL); return TCL_ERROR; case TCL_ERROR: return TCL_ERROR; } Tcl_SetObjResult (interp, listObjPtr); return TCL_OK; } /*----------------------------------------------------------------------------- * TclX_KeyedListInit -- * Initialize the keyed list commands for this interpreter. * * Parameters: * o interp - Interpreter to add commands to. *----------------------------------------------------------------------------- */ void TclX_KeyedListInit (interp) Tcl_Interp *interp; { Tcl_RegisterObjType (&keyedListType); Tcl_CreateObjCommand (interp, "keylget", TclX_KeylgetObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc*) NULL); Tcl_CreateObjCommand (interp, "keylset", TclX_KeylsetObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc*) NULL); Tcl_CreateObjCommand (interp, "keyldel", TclX_KeyldelObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc*) NULL); Tcl_CreateObjCommand (interp, "keylkeys", TclX_KeylkeysObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc*) NULL); } tclx8.4-8.4.1.orig/generic/tclXtest.c0000644000000000000000000001347412046313167014163 0ustar /* * tclXtest.c -- * * Test support functions for the Extended Tcl test program. * *----------------------------------------------------------------------------- * Copyright 1991-1999 Karl Lehenbauer and Mark Diekhans. * * Permission to use, copy, modify, and distribute this software and its * documentation for any purpose and without fee is hereby granted, provided * that the above copyright notice appear in all copies. Karl Lehenbauer and * Mark Diekhans make no representations about the suitability of this * software for any purpose. It is provided "as is" without express or * implied warranty. *----------------------------------------------------------------------------- * $Id: tclXtest.c,v 1.2 2002/04/03 02:50:35 hobbs Exp $ *----------------------------------------------------------------------------- */ #include "tclExtdInt.h" int Tclxtest_Init _ANSI_ARGS_((Tcl_Interp *interp)); int TclObjTest_Init _ANSI_ARGS_((Tcl_Interp *interp)); int Tcltest_Init _ANSI_ARGS_((Tcl_Interp *interp)); /* * Error handler proc that causes errors to come out in the same format as * the standard Tcl test shell. This keeps certain Tcl tests from reporting * errors. */ static char errorHandler [] = "proc tclx_errorHandler msg {global errorInfo; \ if [lempty $errorInfo] {puts $msg} else {puts stderr $errorInfo}; \ exit 1}"; /* * Prototypes of internal functions. */ static int DoTestEval _ANSI_ARGS_((Tcl_Interp *interp, char *levelStr, char *command, Tcl_Obj *resultList)); static int TclxTestEvalCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); /*----------------------------------------------------------------------------- * DoTestEval -- * Evaluate a level/command pair. * Parameters: * o interp - Errors are returned in result. * o levelStr - Level string to parse. * o command - Command to evaluate. * o resultList - List object to append the two element eval code and result * to. * Returns: * TCL_OK or TCL_ERROR. *----------------------------------------------------------------------------- */ static int DoTestEval (interp, levelStr, command, resultList) Tcl_Interp *interp; char *levelStr; char *command; Tcl_Obj *resultList; { Interp *iPtr = (Interp *) interp; int code; Tcl_Obj *subResult; CallFrame *savedVarFramePtr, *framePtr; /* * Find the frame to eval in. */ code = TclGetFrame (interp, levelStr, &framePtr); if (code <= 0) { if (code == 0) TclX_AppendObjResult (interp, "invalid level \"", levelStr, "\"", (char *) NULL); return TCL_ERROR; } /* * Evaluate in the new environment. */ savedVarFramePtr = iPtr->varFramePtr; iPtr->varFramePtr = framePtr; code = Tcl_Eval (interp, command); iPtr->varFramePtr = savedVarFramePtr; /* * Append the two element list. */ subResult = Tcl_NewListObj (0, NULL); if (Tcl_ListObjAppendElement (interp, subResult, Tcl_NewIntObj (code)) != TCL_OK) return TCL_ERROR; if (Tcl_ListObjAppendElement (interp, subResult, Tcl_GetObjResult (interp)) != TCL_OK) return TCL_ERROR; if (Tcl_ListObjAppendElement (interp, resultList, subResult) != TCL_OK) return TCL_ERROR; return TCL_OK; } /*----------------------------------------------------------------------------- * TclxTestEvalCmd -- * Command used in profile test. It purpose is to evaluate a series of * commands at a specified level. Its like uplevel, but can generate more * complex situations. Level is specified in the same manner as uplevel, * with 0 being the current level. * tclx_test_eval ?level cmd? ?level cmd? ... * * Results: * A list contain a list entry for each command evaluated. Each entry is * the eval code and result string. *----------------------------------------------------------------------------- */ static int TclxTestEvalCmd (clientData, interp, argc, argv) ClientData clientData; Tcl_Interp *interp; int argc; char **argv; { int idx; Tcl_Obj *resultList; if (((argc - 1) % 2) != 0) { TclX_AppendObjResult (interp, "wrong # args: ", argv [0], " ?level cmd? ?level cmd? ...", (char *) NULL); return TCL_ERROR; } resultList = Tcl_NewListObj (0, NULL); for (idx = 1; idx < argc; idx += 2) { if (DoTestEval (interp, argv [idx], argv [idx + 1], resultList) == TCL_ERROR) { Tcl_DecrRefCount (resultList); return TCL_ERROR; } } Tcl_SetObjResult (interp, resultList); return TCL_OK; } /*----------------------------------------------------------------------------- * Tclxtest_Init -- * Initialize TclX test support. * * Results: * Returns a standard Tcl completion code, and leaves an error message in * interp result if an error occurs. *----------------------------------------------------------------------------- */ int Tclxtest_Init (interp) Tcl_Interp *interp; { Tcl_CreateCommand (interp, "tclx_test_eval", TclxTestEvalCmd, (ClientData) NULL, (Tcl_CmdDeleteProc*) NULL); /* * Add in standard Tcl tests support. */ if (Tcltest_Init(interp) == TCL_ERROR) { return TCL_ERROR; } Tcl_StaticPackage(interp, "Tcltest", Tcltest_Init, (Tcl_PackageInitProc *) NULL); if (TclObjTest_Init(interp) == TCL_ERROR) { return TCL_ERROR; } return Tcl_GlobalEval (interp, errorHandler); } tclx8.4-8.4.1.orig/generic/tclXbsearch.c0000644000000000000000000003014712046313167014607 0ustar /* * tclXbsearch.c * * Extended Tcl binary file search command. *----------------------------------------------------------------------------- * Copyright 1991-1999 Karl Lehenbauer and Mark Diekhans. * * Permission to use, copy, modify, and distribute this software and its * documentation for any purpose and without fee is hereby granted, provided * that the above copyright notice appear in all copies. Karl Lehenbauer and * Mark Diekhans make no representations about the suitability of this * software for any purpose. It is provided "as is" without express or * implied warranty. *----------------------------------------------------------------------------- * $Id: tclXbsearch.c,v 1.3 2005/04/26 20:01:33 hobbs Exp $ *----------------------------------------------------------------------------- */ #include "tclExtdInt.h" /* * Control block used to pass data used by the binary search routines. */ typedef struct binSearchCB_t { Tcl_Interp *interp; /* Pointer to the interpreter. */ char *key; /* The key to search for. */ Tcl_Channel channel; /* I/O channel. */ Tcl_DString lineBuf; /* Dynamic buffer to hold a line of file. */ off_t lastRecOffset; /* Offset of last record read. */ int cmpResult; /* -1, 0 or 1 result of string compare. */ char *tclProc; /* Name of Tcl comparsion proc, or NULL. */ } binSearchCB_t; /* * Prototypes of internal functions. */ static int StandardKeyCompare _ANSI_ARGS_((char *key, char *line)); static int TclProcKeyCompare _ANSI_ARGS_((binSearchCB_t *searchCBPtr)); static int ReadAndCompare _ANSI_ARGS_((off_t fileOffset, binSearchCB_t *searchCBPtr)); static int BinSearch _ANSI_ARGS_((binSearchCB_t *searchCBPtr)); static int TclX_BsearchObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); /*----------------------------------------------------------------------------- * * StandardKeyCompare -- * Standard comparison routine for BinSearch, compares the key to the * first white-space seperated field in the line. * * Parameters: * o key (I) - The key to search for. * o line (I) - The line to compare the key to. * * Results: * o < 0 if key < line-key * o = 0 if key == line-key * o > 0 if key > line-key. *----------------------------------------------------------------------------- */ static int StandardKeyCompare (key, line) char *key; char *line; { int cmpResult, fieldLen; char saveChar; fieldLen = strcspn (line, " \t\r\n\v\f"); saveChar = line [fieldLen]; line [fieldLen] = 0; cmpResult = strcmp (key, line); line [fieldLen] = saveChar; return cmpResult; } /*----------------------------------------------------------------------------- * TclProcKeyCompare -- * Comparison routine for BinSearch that runs a Tcl procedure to, * compare the key to a line from the file. * * Parameters: * o searchCBPtr (I/O) - The search control block, the line should be in * lineBuf, the comparsion result is returned in cmpResult. * * Results: * TCL_OK or TCL_ERROR. *----------------------------------------------------------------------------- */ static int TclProcKeyCompare (searchCBPtr) binSearchCB_t *searchCBPtr; { CONST84 char *cmdArgv [3]; char *command, *oldResult; int result; cmdArgv [0] = searchCBPtr->tclProc; cmdArgv [1] = searchCBPtr->key; cmdArgv [2] = searchCBPtr->lineBuf.string; command = Tcl_Merge (3, cmdArgv); result = Tcl_Eval (searchCBPtr->interp, command); ckfree (command); if (result == TCL_ERROR) return TCL_ERROR; if (Tcl_GetIntFromObj (searchCBPtr->interp, Tcl_GetObjResult (searchCBPtr->interp), &searchCBPtr->cmpResult) != TCL_OK) { oldResult = Tcl_GetStringFromObj ( Tcl_GetObjResult (searchCBPtr->interp), NULL); oldResult = ckstrdup (oldResult); Tcl_ResetResult (searchCBPtr->interp); TclX_AppendObjResult (searchCBPtr->interp, "invalid integer \"", oldResult, "\" returned from compare proc \"", searchCBPtr->tclProc, "\"", (char *) NULL); ckfree (oldResult); return TCL_ERROR; } Tcl_ResetResult (searchCBPtr->interp); return TCL_OK; } /*----------------------------------------------------------------------------- * ReadAndCompare -- * Search for the next line in the file starting at the specified * offset. Read the line into the dynamic buffer and compare it to * the key using the specified comparison method. The start of the * last line read is saved in the control block, and if the start of * the same line is found in the search, then it will not be recompared. * This is needed since the search algorithm has to hit the same line * a couple of times before failing, due to the fact that the records are * not fixed length. * * Parameters: * o fileOffset (I) - The offset of the next byte of the search, not * necessarly the start of a record. * o searchCBPtr (I/O) - The search control block, the comparsion result * is returned in cmpResult. If the EOF is hit, a less-than result is * returned. * * Results: * TCL_OK or TCL_ERROR. *----------------------------------------------------------------------------- */ static int ReadAndCompare (fileOffset, searchCBPtr) off_t fileOffset; binSearchCB_t *searchCBPtr; { if (Tcl_Seek (searchCBPtr->channel, fileOffset, SEEK_SET) < 0) goto posixError; /* * Go to beginning of next line by reading the remainder of the current * one. */ if (fileOffset != 0) { if (Tcl_Gets (searchCBPtr->channel, &searchCBPtr->lineBuf) < 0) { if (Tcl_Eof (searchCBPtr->channel) || Tcl_InputBlocked (searchCBPtr->channel)) { TclX_AppendObjResult (searchCBPtr->interp, "bsearch got unexpected EOF on \"", Tcl_GetChannelName (searchCBPtr->channel), "\"", (char *) NULL); return TCL_ERROR; } goto posixError; } } fileOffset = (off_t) Tcl_Tell (searchCBPtr->channel); /* Offset of next line */ /* * If this is the same line as before, then just leave the comparison * result unchanged. */ if (fileOffset == searchCBPtr->lastRecOffset) return TCL_OK; searchCBPtr->lastRecOffset = fileOffset; Tcl_DStringSetLength (&searchCBPtr->lineBuf, 0); /* * Read the line. Only compare if EOF was not hit, otherwise, treat as if * we went above the key we are looking for. */ if (Tcl_Gets (searchCBPtr->channel, &searchCBPtr->lineBuf) < 0) { if (Tcl_Eof (searchCBPtr->channel) || Tcl_InputBlocked (searchCBPtr->channel)) { searchCBPtr->cmpResult = -1; return TCL_OK; } goto posixError; } /* * Compare the line. */ if (searchCBPtr->tclProc == NULL) { searchCBPtr->cmpResult = StandardKeyCompare (searchCBPtr->key, searchCBPtr->lineBuf.string); } else { if (TclProcKeyCompare (searchCBPtr) != TCL_OK) return TCL_ERROR; } return TCL_OK; posixError: TclX_AppendObjResult (searchCBPtr->interp, Tcl_GetChannelName (searchCBPtr->channel), ": ", Tcl_PosixError (searchCBPtr->interp), (char *) NULL); return TCL_ERROR; } /*----------------------------------------------------------------------------- * BinSearch -- * Binary search a sorted ASCII file. * * Parameters: * o searchCBPtr (I/O) - The search control block, if the line is found, * it is returned in lineBuf. * Results: * TCL_OK - If the key was found. * TCL_BREAK - If it was not found. * TCL_ERROR - If there was an error. * * based on getpath.c from smail 2.5 (9/15/87) * *----------------------------------------------------------------------------- */ static int BinSearch (searchCBPtr) binSearchCB_t *searchCBPtr; { off_t middle, high, low; low = 0; if (TclXOSGetFileSize (searchCBPtr->channel, &high) != TCL_OK) goto posixError; /* * "Binary search routines are never written right the first time around." * - Robert G. Sheldon. */ while (TRUE) { middle = (high + low + 1) / 2; if (ReadAndCompare (middle, searchCBPtr) != TCL_OK) return TCL_ERROR; if (searchCBPtr->cmpResult == 0) return TCL_OK; /* Found */ if (low >= middle) return TCL_BREAK; /* Failure */ /* * Close window. */ if (searchCBPtr->cmpResult > 0) { low = middle; } else { high = middle - 1; } } posixError: TclX_AppendObjResult (searchCBPtr->interp, Tcl_GetChannelName (searchCBPtr->channel), ": ", Tcl_PosixError (searchCBPtr->interp), (char *) NULL); return TCL_ERROR; } /*----------------------------------------------------------------------------- * TclX_BsearchObjCmd -- * Implements the TCL bsearch command: * bsearch filehandle key ?retvar? *----------------------------------------------------------------------------- */ static int TclX_BsearchObjCmd (clientData, interp, objc, objv) ClientData clientData; Tcl_Interp *interp; int objc; Tcl_Obj *CONST objv[]; { int status; binSearchCB_t searchCB; if ((objc < 3) || (objc > 5)) { TclX_WrongArgs (interp, objv [0], "handle key ?retvar? ?compare_proc?"); return TCL_ERROR; } searchCB.channel = TclX_GetOpenChannelObj (interp, objv [1], TCL_READABLE); if (searchCB.channel == NULL) return TCL_ERROR; searchCB.interp = interp; searchCB.key = Tcl_GetStringFromObj (objv [2], NULL); searchCB.lastRecOffset = -1; searchCB.tclProc = (objc == 5) ? Tcl_GetStringFromObj (objv [4], NULL) : NULL; Tcl_DStringInit (&searchCB.lineBuf); status = BinSearch (&searchCB); if (status == TCL_ERROR) { Tcl_DStringFree (&searchCB.lineBuf); return TCL_ERROR; } if (status == TCL_BREAK) { if ((objc >= 4) && !TclX_IsNullObj (objv [3])) Tcl_SetBooleanObj (Tcl_GetObjResult (interp), FALSE); goto okExit; } if ((objc == 3) || TclX_IsNullObj (objv [3])) { Tcl_SetStringObj (Tcl_GetObjResult (interp), Tcl_DStringValue (&searchCB.lineBuf), -1); } else { Tcl_Obj *valPtr; valPtr = Tcl_NewStringObj (Tcl_DStringValue (&searchCB.lineBuf), -1); if (Tcl_ObjSetVar2(interp, objv[3], NULL, valPtr, TCL_PARSE_PART1|TCL_LEAVE_ERR_MSG) == NULL) { Tcl_DecrRefCount (valPtr); goto errorExit; } Tcl_SetBooleanObj (Tcl_GetObjResult (interp), TRUE); } okExit: Tcl_DStringFree (&searchCB.lineBuf); return TCL_OK; errorExit: Tcl_DStringFree (&searchCB.lineBuf); return TCL_OK; } /*----------------------------------------------------------------------------- * TclX_BsearchInit -- * Initialize the bsearch command. *----------------------------------------------------------------------------- */ void TclX_BsearchInit (interp) Tcl_Interp *interp; { Tcl_CreateObjCommand (interp, "bsearch", TclX_BsearchObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc*) NULL); } tclx8.4-8.4.1.orig/generic/tclXmath.c0000644000000000000000000002370312046313170014123 0ustar /* * tclXmath.c -- * * Mathematical Tcl commands. *----------------------------------------------------------------------------- * Copyright 1991-1999 Karl Lehenbauer and Mark Diekhans. * * Permission to use, copy, modify, and distribute this software and its * documentation for any purpose and without fee is hereby granted, provided * that the above copyright notice appear in all copies. Karl Lehenbauer and * Mark Diekhans make no representations about the suitability of this * software for any purpose. It is provided "as is" without express or * implied warranty. * * Copyright 2005 ActiveState Corporation. * *----------------------------------------------------------------------------- * $Id: tclXmath.c,v 1.3 2005/11/21 18:39:25 hobbs Exp $ *----------------------------------------------------------------------------- */ #include "tclExtdInt.h" #ifndef tclx_random # define tclx_srandom srandom # define tclx_random random #endif #ifdef TCL_WIDE_INT_TYPE #define GET_DOUBLE_VALUE(doubleVar, argPtr, type) \ if ((type) == TCL_INT) { \ (doubleVar) = (double) (argPtr).intValue; \ } else if ((type) == TCL_WIDE_INT) { \ (doubleVar) = Tcl_WideAsDouble((argPtr).wideValue); \ } else { /* TCL_DOUBLE */ \ (doubleVar) = (argPtr).doubleValue; \ } #else #define GET_DOUBLE_VALUE(doubleVar, argPtr, type) \ if ((type) == TCL_INT) { \ (doubleVar) = (double) (argPtr).intValue; \ } else { /* TCL_DOUBLE */ \ (doubleVar) = (argPtr).doubleValue; \ } #endif /* * Prototypes of internal functions. */ static int ConvertIntOrDoubleObj (Tcl_Interp *interp, Tcl_Obj *numStrObj, double *valuePtr); static long ReallyRandom (long my_range); static int TclX_MaxObjCmd (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); static int TclX_MinObjCmd (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); static int TclX_MinMaxFunc (ClientData clientData, Tcl_Interp *interp, Tcl_Value *args, Tcl_Value *resultPtr); static int TclX_RandomObjCmd (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); /*----------------------------------------------------------------------------- * ConvertIntOrDoubleObj -- * * Convert a number object that can be in any legal integer or floating point * format (including integer hex and octal specifications) to a double. * * Parameters: * o interp (I) - Interpreters, errors are returns in result. * o numStr (I) - Number to convert. * o valuePtr (O) - Double value is returned here. * Returns: * TCL_OK or TCL_ERROR. *----------------------------------------------------------------------------- */ static int ConvertIntOrDoubleObj (interp, numStrObj, valuePtr) Tcl_Interp *interp; Tcl_Obj *numStrObj; double *valuePtr; { #ifdef TCL_WIDE_INT_TYPE Tcl_WideInt wVal; if (Tcl_GetWideIntFromObj (interp, numStrObj, &wVal) == TCL_OK) { *valuePtr = Tcl_WideAsDouble(wVal); return TCL_OK; } #else long lvalue; if (Tcl_GetLongFromObj (interp, numStrObj, &lvalue) == TCL_OK) { *valuePtr = (double) lvalue; return TCL_OK; } #endif if (Tcl_GetDoubleFromObj (interp, numStrObj, valuePtr) == TCL_OK) return TCL_OK; return TCL_ERROR; } /*----------------------------------------------------------------------------- * TclX_MaxObjCmd -- * Implements the Tcl max command: * max num1 ?..numN? * * Results: * Standard TCL results. *----------------------------------------------------------------------------- */ static int TclX_MaxObjCmd (clientData, interp, objc, objv) ClientData clientData; Tcl_Interp *interp; int objc; Tcl_Obj *CONST objv[]; { double value, maxValue = -MAXDOUBLE; int idx, maxIdx = 1; if (objc < 2) return TclX_WrongArgs (interp, objv[0], "num1 ?..numN?"); for (idx = 1; idx < objc; idx++) { if (ConvertIntOrDoubleObj (interp, objv [idx], &value) != TCL_OK) return TCL_ERROR; if (value > maxValue) { maxValue = value; maxIdx = idx; } } Tcl_SetObjResult (interp, objv [maxIdx]); return TCL_OK; } /*----------------------------------------------------------------------------- * TclX_MinObjCmd -- * Implements the TCL min command: * min num1 ?..numN? * * Results: * Standard TCL results. *----------------------------------------------------------------------------- */ static int TclX_MinObjCmd (clientData, interp, objc, objv) ClientData clientData; Tcl_Interp *interp; int objc; Tcl_Obj *CONST objv[]; { double value, minValue = MAXDOUBLE; int idx, minIdx = 1; if (objc < 2) return TclX_WrongArgs (interp, objv[0], "num1 ?..numN?"); for (idx = 1; idx < objc; idx++) { if (ConvertIntOrDoubleObj (interp, objv [idx], &value) != TCL_OK) return TCL_ERROR; if (value < minValue) { minValue = value; minIdx = idx; } } Tcl_SetObjResult (interp, objv [minIdx]); return TCL_OK; } /*----------------------------------------------------------------------------- * * TclX_MaxFunc -- * Implements the Tcl max math function * expr max(num1, num2) * * Results: * Standard TCL results. * *----------------------------------------------------------------------------- */ static int TclX_MinMaxFunc (clientData, interp, args, resultPtr) ClientData clientData; Tcl_Interp *interp; Tcl_Value *args; Tcl_Value *resultPtr; { size_t isMax = (size_t) clientData; Tcl_ValueType t0 = args[0].type; Tcl_ValueType t1 = args[1].type; if ((t1 == TCL_DOUBLE) || (t0 == TCL_DOUBLE)) { double d0, d1; /* * Compare as doubles. */ GET_DOUBLE_VALUE(d0, args[0], t0); GET_DOUBLE_VALUE(d1, args[1], t1); resultPtr->type = TCL_DOUBLE; if (isMax) { resultPtr->doubleValue = (d0 < d1) ? d1 : d0; } else { resultPtr->doubleValue = (d0 > d1) ? d1 : d0; } #ifdef TCL_WIDE_INT_TYPE } else if ((t1 == TCL_WIDE_INT) || (t0 == TCL_WIDE_INT)) { Tcl_WideInt w0, w1; /* * Compare as wide ints (neither are doubles) */ w0 = (t0 == TCL_INT) ? Tcl_LongAsWide(args[0].intValue) : args[0].wideValue; w1 = (t1 == TCL_INT) ? Tcl_LongAsWide(args[1].intValue) : args[1].wideValue; resultPtr->type = TCL_WIDE_INT; if (isMax) { resultPtr->wideValue = (w0 < w1) ? w1 : w0; } else { resultPtr->wideValue = (w0 > w1) ? w1 : w0; } #endif } else { /* * Compare as ints. */ long i0 = args[0].intValue; long i1 = args[1].intValue; resultPtr->type = TCL_INT; if (isMax) { resultPtr->intValue = (i0 < i1) ? i1 : i0; } else { resultPtr->intValue = (i0 > i1) ? i1 : i0; } } return TCL_OK; } /*----------------------------------------------------------------------------- * ReallyRandom -- * Insure a good random return for a range, unlike an arbitrary * random() % n, thanks to Ken Arnold, Unix Review, October 1987. *----------------------------------------------------------------------------- */ #define RANDOM_RANGE 0x7fffffffL static long ReallyRandom (myRange) long myRange; { long maxMultiple, rnum; maxMultiple = RANDOM_RANGE / myRange; maxMultiple *= myRange; while ((rnum = tclx_random ()) >= maxMultiple) continue; return (rnum % myRange); } /*----------------------------------------------------------------------------- * TclX_RandomObjCmd -- * Implements the TCL random command: * random limit | seed ?seedval? * * Results: * Standard TCL results. *----------------------------------------------------------------------------- */ static int TclX_RandomObjCmd (dummy, interp, objc, objv) ClientData dummy; Tcl_Interp *interp; int objc; Tcl_Obj *CONST objv[]; { long range; char *seedString; if ((objc < 2) || (objc > 3)) goto invalidArgs; if (Tcl_GetLongFromObj ((Tcl_Interp *) NULL, objv [1], &range) == TCL_OK) { if (objc != 2) goto invalidArgs; if ((range <= 0) || (range > RANDOM_RANGE)) goto outOfRange; } else { int seed; seedString = Tcl_GetStringFromObj (objv [1], NULL); if (!STREQU (seedString, "seed")) goto invalidArgs; if (objc == 3) { if (Tcl_GetIntFromObj (interp, objv[2], &seed) != TCL_OK) return TCL_ERROR; } else { seed = (getpid () + time ((time_t *)NULL)); } (void) tclx_srandom (seed); return TCL_OK; } Tcl_SetIntObj (Tcl_GetObjResult (interp), ReallyRandom (range)); return TCL_OK; invalidArgs: return TclX_WrongArgs (interp, objv[0], "limit | seed ?seedval?"); outOfRange: { char buf [18]; sprintf (buf, "%ld", RANDOM_RANGE); TclX_AppendObjResult (interp, " range must be > 0 and <= ", buf, (char *) NULL); return TCL_ERROR; } } /*----------------------------------------------------------------------------- * TclX_MathInit -- * * Initialize the TclX math commands and functions. *----------------------------------------------------------------------------- */ void TclX_MathInit (interp) Tcl_Interp *interp; { int major, minor; Tcl_ValueType minMaxArgTypes[2]; minMaxArgTypes[0] = TCL_EITHER; minMaxArgTypes[1] = TCL_EITHER; Tcl_CreateObjCommand (interp, "max", TclX_MaxObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc*) NULL); Tcl_CreateObjCommand (interp, "min", TclX_MinObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc*) NULL); Tcl_CreateObjCommand (interp, "random", TclX_RandomObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc*) NULL); /* * Tcl 8.5 added core min/max expr functions */ Tcl_GetVersion(&major, &minor, NULL, NULL); if ((major == 8) && (minor <= 4)) { Tcl_CreateMathFunc(interp, "max", 2, minMaxArgTypes, TclX_MinMaxFunc, (ClientData) 1 /* IS_MAX */); Tcl_CreateMathFunc (interp, "min", 2, minMaxArgTypes, TclX_MinMaxFunc, (ClientData) 0 /* IS_MIN */); } } tclx8.4-8.4.1.orig/generic/tclXdebug.c0000644000000000000000000004460612046313167014273 0ustar /* * tclXdebug.c -- * * Tcl command execution trace command. *----------------------------------------------------------------------------- * Copyright 1991-1999 Karl Lehenbauer and Mark Diekhans. * * Permission to use, copy, modify, and distribute this software and its * documentation for any purpose and without fee is hereby granted, provided * that the above copyright notice appear in all copies. Karl Lehenbauer and * Mark Diekhans make no representations about the suitability of this * software for any purpose. It is provided "as is" without express or * implied warranty. *----------------------------------------------------------------------------- * $Id: tclXdebug.c,v 1.3 2002/09/26 00:19:18 hobbs Exp $ *----------------------------------------------------------------------------- */ #include "tclExtdInt.h" /* * Client data structure for the cmdtrace command. */ #define ARG_TRUNCATE_SIZE 40 #define CMD_TRUNCATE_SIZE 60 typedef struct traceInfo_t { Tcl_Interp *interp; Tcl_Trace traceId; int inTrace; int noEval; int noTruncate; int procCalls; int depth; char *callback; Tcl_Obj *errorStatePtr; Tcl_AsyncHandler errorAsyncHandler; Tcl_Channel channel; } traceInfo_t, *traceInfo_pt; /* * Prototypes of internal functions. */ static void TraceDelete _ANSI_ARGS_((Tcl_Interp *interp, traceInfo_pt infoPtr)); static void PrintStr _ANSI_ARGS_((Tcl_Channel channel, CONST84 char *string, int numChars, int quoted)); static void PrintArg _ANSI_ARGS_((Tcl_Channel channel, CONST84 char *argStr, int noTruncate)); static void TraceCode _ANSI_ARGS_((traceInfo_pt infoPtr, int level, char *command, int argc, CONST84 char **argv)); static int TraceCallbackErrorHandler _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int code)); static void TraceCallBack _ANSI_ARGS_((Tcl_Interp *interp, traceInfo_pt infoPtr, int level, char *command, int argc, CONST84 char **argv)); static void CmdTraceRoutine _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int level, char *command, Tcl_CmdProc *cmdProc, ClientData cmdClientData, int argc, CONST84 char **argv)); static int TclX_CmdtraceObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static void DebugCleanUp _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp)); /*----------------------------------------------------------------------------- * TraceDelete -- * * Delete the trace if active, reseting the structure. *----------------------------------------------------------------------------- */ static void TraceDelete (interp, infoPtr) Tcl_Interp *interp; traceInfo_pt infoPtr; { if (infoPtr->traceId != NULL) { Tcl_DeleteTrace (interp, infoPtr->traceId); infoPtr->depth = 0; infoPtr->traceId = NULL; if (infoPtr->callback != NULL) { ckfree (infoPtr->callback); infoPtr->callback = NULL; } } if (infoPtr->errorAsyncHandler != NULL) { Tcl_AsyncDelete (infoPtr->errorAsyncHandler); infoPtr->errorAsyncHandler = NULL; } } /*----------------------------------------------------------------------------- * PrintStr -- * * Print an string, truncating it to the specified number of characters. * If the string contains newlines, \n is substituted. *----------------------------------------------------------------------------- */ static void PrintStr (channel, string, numChars, quoted) Tcl_Channel channel; CONST84 char *string; int numChars; int quoted; { int idx; if (quoted) Tcl_Write (channel, "{", 1); for (idx = 0; idx < numChars; idx++) { if (string [idx] == '\n') { Tcl_Write (channel, "\\n", 2); } else { Tcl_Write (channel, &(string [idx]), 1); } } if (numChars < (int) strlen (string)) Tcl_Write (channel, "...", 3); if (quoted) Tcl_Write (channel, "}", 1); } /*----------------------------------------------------------------------------- * PrintArg -- * * Print an argument string, truncating and adding "..." if its longer * then ARG_TRUNCATE_SIZE. If the string contains white spaces, quote * it with braces. *----------------------------------------------------------------------------- */ static void PrintArg (channel, argStr, noTruncate) Tcl_Channel channel; CONST84 char *argStr; int noTruncate; { int idx, argLen, printLen; int quoted; argLen = strlen (argStr); printLen = argLen; if ((!noTruncate) && (printLen > ARG_TRUNCATE_SIZE)) printLen = ARG_TRUNCATE_SIZE; quoted = (printLen == 0); for (idx = 0; idx < printLen; idx++) if (ISSPACE (argStr [idx])) { quoted = TRUE; break; } PrintStr (channel, argStr, printLen, quoted); } /*----------------------------------------------------------------------------- * TraceCode -- * * Print out a trace of a code line. Level is used for indenting * and marking lines and may be eval or procedure level. *----------------------------------------------------------------------------- */ static void TraceCode (infoPtr, level, command, argc, argv) traceInfo_pt infoPtr; int level; char *command; int argc; CONST84 char **argv; { int idx, cmdLen, printLen; char buf [32]; sprintf (buf, "%2d:", level); Tcl_Write(infoPtr->channel, buf, -1); if (level > 20) level = 20; for (idx = 0; idx < level; idx++) Tcl_Write (infoPtr->channel, " ", 2); if (infoPtr->noEval) { cmdLen = printLen = strlen (command); if ((!infoPtr->noTruncate) && (printLen > CMD_TRUNCATE_SIZE)) printLen = CMD_TRUNCATE_SIZE; PrintStr (infoPtr->channel, (CONST84 char *) command, printLen, FALSE); } else { for (idx = 0; idx < argc; idx++) { if (idx > 0) Tcl_Write (infoPtr->channel, " ", 1); PrintArg (infoPtr->channel, argv [idx], infoPtr->noTruncate); } } TclX_WriteNL (infoPtr->channel); Tcl_Flush (infoPtr->channel); } /*----------------------------------------------------------------------------- * TraceCallbackErrorHandler -- * * Async handler that processes an callback error. Generates either an * immediate or background error. *----------------------------------------------------------------------------- */ static int TraceCallbackErrorHandler (clientData, interp, code) ClientData clientData; Tcl_Interp *interp; int code; { traceInfo_pt infoPtr = (traceInfo_pt) clientData; /* * Put back error message and state. If not interp passed in, the error * is handled in the background. */ TclX_RestoreResultErrorInfo (infoPtr->interp, infoPtr->errorStatePtr); infoPtr->errorStatePtr = NULL; if (interp == NULL) { Tcl_BackgroundError (infoPtr->interp); } TraceDelete (interp, infoPtr); return TCL_ERROR; } /*----------------------------------------------------------------------------- * TraceCallBack -- * * Build and call a callback for the command that was just executed. The * following arguments are appended to the command: * 1) command - A string containing the text of the command, before any * argument substitution. * 2) argv - A list of the final argument information that will be passed to * the command after command, variable, and backslash substitution. * 3) evalLevel - The Tcl_Eval level. * 4) procLevel - The procedure level. * The code should allow for additional substitution of arguments in future * versions (such as a procedure with args as the last argument). The value * of result, errorInfo and errorCode are preserved. All other state must be * preserved by the procedure. An error will result in an error being flagged * in the control block and async mark being called to handle the error * once the command has completed. *----------------------------------------------------------------------------- */ static void TraceCallBack (interp, infoPtr, level, command, argc, argv) Tcl_Interp *interp; traceInfo_pt infoPtr; int level; char *command; int argc; CONST84 char **argv; { Interp *iPtr = (Interp *) interp; Tcl_DString callback; Tcl_Obj *saveObjPtr; char *cmdList; char numBuf [32]; Tcl_DStringInit (&callback); /* * Build the command to evaluate. */ Tcl_DStringAppend (&callback, infoPtr->callback, -1); Tcl_DStringStartSublist (&callback); Tcl_DStringAppendElement (&callback, command); Tcl_DStringEndSublist (&callback); Tcl_DStringStartSublist (&callback); cmdList = Tcl_Merge (argc, argv); Tcl_DStringAppendElement (&callback, cmdList); ckfree (cmdList); Tcl_DStringEndSublist (&callback); sprintf (numBuf, "%d", level); Tcl_DStringAppendElement (&callback, numBuf); sprintf (numBuf, "%d", ((iPtr->varFramePtr == NULL) ? 0 : iPtr->varFramePtr->level)); Tcl_DStringAppendElement (&callback, numBuf); saveObjPtr = TclX_SaveResultErrorInfo (interp); /* * Evaluate the command. If an error occurs, set up the handler to be * called when its possible. */ if (Tcl_Eval (interp, Tcl_DStringValue (&callback)) == TCL_ERROR) { Tcl_AddObjErrorInfo (interp, "\n (\"cmdtrace\" callback command)", -1); infoPtr->errorStatePtr = TclX_SaveResultErrorInfo (interp); Tcl_AsyncMark (infoPtr->errorAsyncHandler); } TclX_RestoreResultErrorInfo (interp, saveObjPtr); Tcl_DStringFree (&callback); } /*----------------------------------------------------------------------------- * CmdTraceRoutine -- * * Routine called by Tcl_Eval to trace a command. *----------------------------------------------------------------------------- */ static void CmdTraceRoutine (clientData, interp, level, command, cmdProc, cmdClientData, argc, argv) ClientData clientData; Tcl_Interp *interp; int level; char *command; Tcl_CmdProc *cmdProc; ClientData cmdClientData; int argc; CONST84 char **argv; { Interp *iPtr = (Interp *) interp; traceInfo_pt infoPtr = (traceInfo_pt) clientData; int procLevel; /* * If we are in an error. */ if (infoPtr->inTrace || (infoPtr->errorStatePtr != NULL)) { return; } infoPtr->inTrace = TRUE; if (infoPtr->procCalls) { if (TclFindProc (iPtr, argv [0]) != NULL) { if (infoPtr->callback != NULL) { TraceCallBack (interp, infoPtr, level, command, argc, argv); } else { procLevel = (iPtr->varFramePtr == NULL) ? 0 : iPtr->varFramePtr->level; TraceCode (infoPtr, procLevel, command, argc, argv); } } } else { if (infoPtr->callback != NULL) { TraceCallBack (interp, infoPtr, level, command, argc, argv); } else { TraceCode (infoPtr, level, command, argc, argv); } } infoPtr->inTrace = FALSE; } /*----------------------------------------------------------------------------- * Tcl_CmdtraceObjCmd -- * * Implements the TCL trace command: * cmdtrace level|on ?noeval? ?notruncate? ?procs? ?fileid? ?command cmd? * cmdtrace off * cmdtrace depth *----------------------------------------------------------------------------- */ static int TclX_CmdtraceObjCmd (clientData, interp, objc, objv) ClientData clientData; Tcl_Interp *interp; int objc; Tcl_Obj *CONST objv[]; { traceInfo_pt infoPtr = (traceInfo_pt) clientData; int idx; char *argStr, *callback; Tcl_Obj *channelId; if (objc < 2) goto argumentError; argStr = Tcl_GetStringFromObj (objv [1], NULL); /* * Handle `depth' sub-command. */ if (STREQU (argStr, "depth")) { if (objc != 2) goto argumentError; Tcl_SetIntObj (Tcl_GetObjResult (interp), infoPtr->depth); return TCL_OK; } /* * If a trace is in progress, delete it now. */ TraceDelete (interp, infoPtr); /* * Handle off sub-command. */ if (STREQU (argStr, "off")) { if (objc != 2) goto argumentError; return TCL_OK; } infoPtr->noEval = FALSE; infoPtr->noTruncate = FALSE; infoPtr->procCalls = FALSE; infoPtr->channel = NULL; channelId = NULL; callback = NULL; if (STREQU (argStr, "on")) { infoPtr->depth = MAXINT; } else { if (Tcl_GetIntFromObj (interp, objv [1], &(infoPtr->depth)) != TCL_OK) return TCL_ERROR; } for (idx = 2; idx < objc; idx++) { argStr = Tcl_GetStringFromObj (objv [idx], NULL); if (STREQU (argStr, "notruncate")) { if (infoPtr->noTruncate) goto argumentError; infoPtr->noTruncate = TRUE; continue; } if (STREQU (argStr, "noeval")) { if (infoPtr->noEval) goto argumentError; infoPtr->noEval = TRUE; continue; } if (STREQU (argStr, "procs")) { if (infoPtr->procCalls) goto argumentError; infoPtr->procCalls = TRUE; continue; } if (STRNEQU (argStr, "std", 3) || STRNEQU (argStr, "file", 4)) { if (channelId != NULL) goto argumentError; if (callback != NULL) goto mixCommandAndFile; channelId = objv [idx]; continue; } if (STREQU (argStr, "command")) { if (callback != NULL) goto argumentError; if (channelId != NULL) goto mixCommandAndFile; if (idx == objc - 1) goto missingCommand; callback = Tcl_GetStringFromObj (objv [++idx], NULL); continue; } goto invalidOption; } if (callback != NULL) { infoPtr->callback = ckstrdup (callback); infoPtr->errorAsyncHandler = Tcl_AsyncCreate (TraceCallbackErrorHandler, (ClientData) infoPtr); } else { if (channelId == NULL) { infoPtr->channel = TclX_GetOpenChannel (interp, "stdout", TCL_WRITABLE); } else { infoPtr->channel = TclX_GetOpenChannelObj (interp, channelId, TCL_WRITABLE); } if (infoPtr->channel == NULL) return TCL_ERROR; } infoPtr->traceId = Tcl_CreateTrace (interp, infoPtr->depth, (Tcl_CmdTraceProc*) CmdTraceRoutine, (ClientData) infoPtr); return TCL_OK; argumentError: TclX_AppendObjResult (interp, tclXWrongArgs, objv [0], " level | on ?noeval? ?notruncate? ?procs?", "?fileid? ?command cmd? | off | depth", (char *) NULL); return TCL_ERROR; missingCommand: TclX_AppendObjResult (interp, "command option requires an argument", (char *) NULL); return TCL_ERROR; mixCommandAndFile: TclX_AppendObjResult (interp, "can not specify both the command option ", "and a file handle", (char *) NULL); return TCL_ERROR; invalidOption: TclX_AppendObjResult (interp, "invalid option: expected ", "one of \"noeval\", \"notruncate\", \"procs\", ", "\"command\", or a file id", (char *) NULL); return TCL_ERROR; } /*----------------------------------------------------------------------------- * DebugCleanUp -- * * Release the debug data area when the interpreter is deleted. *----------------------------------------------------------------------------- */ static void DebugCleanUp (clientData, interp) ClientData clientData; Tcl_Interp *interp; { traceInfo_pt infoPtr = (traceInfo_pt) clientData; TraceDelete (interp, infoPtr); ckfree ((char *) infoPtr); } /*----------------------------------------------------------------------------- * TclX_DebugInit -- * * Initialize the TCL debugging commands. *----------------------------------------------------------------------------- */ void TclX_DebugInit (interp) Tcl_Interp *interp; { traceInfo_pt infoPtr; infoPtr = (traceInfo_pt) ckalloc (sizeof (traceInfo_t)); infoPtr->interp = interp; infoPtr->traceId = NULL; infoPtr->inTrace = FALSE; infoPtr->noEval = FALSE; infoPtr->noTruncate = FALSE; infoPtr->procCalls = FALSE; infoPtr->depth = 0; infoPtr->callback = NULL; infoPtr->errorStatePtr = NULL; infoPtr->errorAsyncHandler = NULL; infoPtr->channel = NULL; Tcl_CallWhenDeleted (interp, DebugCleanUp, (ClientData) infoPtr); Tcl_CreateObjCommand (interp, "cmdtrace", TclX_CmdtraceObjCmd, (ClientData) infoPtr, (Tcl_CmdDeleteProc*) NULL); } tclx8.4-8.4.1.orig/generic/tclExtend.h0000644000000000000000000001317012046313167014301 0ustar /* * tclExtend.h * * External declarations for the extended Tcl library. *----------------------------------------------------------------------------- * Copyright 1991-1999 Karl Lehenbauer and Mark Diekhans. * * Permission to use, copy, modify, and distribute this software and its * documentation for any purpose and without fee is hereby granted, provided * that the above copyright notice appear in all copies. Karl Lehenbauer and * Mark Diekhans make no representations about the suitability of this * software for any purpose. It is provided "as is" without express or * implied warranty. *----------------------------------------------------------------------------- * $Id: tclExtend.h,v 1.5 2002/09/26 00:23:29 hobbs Exp $ *----------------------------------------------------------------------------- */ #ifndef TCLEXTEND_H #define TCLEXTEND_H #include #include "tcl.h" /* * The following is needed on Windows to deal with export/import of DLL * functions. See tcl???/win/README. */ #if defined(BUILD_tclx) || defined(BUILD_TCLX) # undef TCL_STORAGE_CLASS # define TCL_STORAGE_CLASS DLLEXPORT #endif #ifndef CONST84 # define CONST84 #endif /* * The TCLX_DEBUG flag turns on asserts etc. Its an internal flag, however * its normally true for alpha and beta release and false for final releases, * so we put the flag right by the version numbers in hopes that we will * remember to change it. #define TCLX_DEBUG */ #define TCLX_PATCHLEVEL 0 /* * Generic void pointer. */ typedef void *void_pt; /* * Flags to command loop functions. */ #define TCLX_CMDL_INTERACTIVE (1<<0) #define TCLX_CMDL_EXIT_ON_EOF (1<<1) /* * Application signal error handler. Called after normal signal processing, * when a signal results in an error. Its main purpose in life is to allow * interactive command loops to clear their input buffer on SIGINT. This is * not currently a generic interface, but should be. Only one maybe active. * This is an undocumented interface. Its in the external file in case * someone needs this facility. It might change in the future. Let us * know if you need this functionality. */ typedef int (*TclX_AppSignalErrorHandler) _ANSI_ARGS_((Tcl_Interp *interp, ClientData clientData, int background, int signalNum)); /* * Exported TclX initialization functions. */ EXTERN int Tclx_Init _ANSI_ARGS_((Tcl_Interp *interp)); EXTERN int Tclx_SafeInit _ANSI_ARGS_((Tcl_Interp *interp)); EXTERN int Tclx_InitStandAlone _ANSI_ARGS_((Tcl_Interp *interp)); EXTERN void TclX_PrintResult _ANSI_ARGS_((Tcl_Interp *interp, int intResult, char *checkCmd)); EXTERN void TclX_SetupSigInt _ANSI_ARGS_((void)); EXTERN void TclX_SetAppSignalErrorHandler _ANSI_ARGS_(( TclX_AppSignalErrorHandler errorFunc, ClientData clientData)); EXTERN void TclX_SetAppInfo _ANSI_ARGS_((int defaultValues, char *appName, char *appLongName, char *appVersion, int appPatchlevel)); EXTERN void TclX_SplitWinCmdLine _ANSI_ARGS_((int *argcPtr, char ***argvPtr)); /* * Exported utility functions. */ EXTERN void TclX_AppendObjResult _ANSI_ARGS_(TCL_VARARGS_DEF(Tcl_Interp *, interpArg)); EXTERN char * TclX_DownShift _ANSI_ARGS_((char *targetStr, CONST char *sourceStr)); EXTERN int TclX_StrToInt _ANSI_ARGS_((CONST char *string, int base, int *intPtr)); EXTERN int TclX_StrToUnsigned _ANSI_ARGS_((CONST char *string, int base, unsigned *unsignedPtr)); EXTERN char * TclX_UpShift _ANSI_ARGS_((char *targetStr, CONST char *sourceStr)); /* * Exported keyed list object manipulation functions. */ EXTERN Tcl_Obj * TclX_NewKeyedListObj _ANSI_ARGS_((void)); EXTERN int TclX_KeyedListGet _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *keylPtr, char *key, Tcl_Obj **valuePtrPtr)); EXTERN int TclX_KeyedListSet _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *keylPtr, char *key, Tcl_Obj *valuePtr)); EXTERN int TclX_KeyedListDelete _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *keylPtr, char *key)); EXTERN int TclX_KeyedListGetKeys _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *keylPtr, char *key, Tcl_Obj **listObjPtrPtr)); /* * Exported handle table manipulation functions. */ EXTERN void_pt TclX_HandleAlloc _ANSI_ARGS_((void_pt headerPtr, char *handlePtr)); EXTERN void TclX_HandleFree _ANSI_ARGS_((void_pt headerPtr, void_pt entryPtr)); EXTERN void_pt TclX_HandleTblInit _ANSI_ARGS_((CONST char *handleBase, int entrySize, int initEntries)); EXTERN void TclX_HandleTblRelease _ANSI_ARGS_((void_pt headerPtr)); EXTERN int TclX_HandleTblUseCount _ANSI_ARGS_((void_pt headerPtr, int amount)); EXTERN void_pt TclX_HandleWalk _ANSI_ARGS_((void_pt headerPtr, int *walkKeyPtr)); EXTERN void TclX_WalkKeyToHandle _ANSI_ARGS_((void_pt headerPtr, int walkKey, char *handlePtr)); EXTERN void_pt TclX_HandleXlate _ANSI_ARGS_((Tcl_Interp *interp, void_pt headerPtr, CONST char *handle)); EXTERN void_pt TclX_HandleXlateObj _ANSI_ARGS_((Tcl_Interp *interp, void_pt headerPtr, Tcl_Obj *handleObj)); /* * Command loop functions. */ EXTERN int TclX_CommandLoop _ANSI_ARGS_((Tcl_Interp *interp, int options, char *endCommand, char *prompt1, char *prompt2)); EXTERN int TclX_AsyncCommandLoop _ANSI_ARGS_((Tcl_Interp *interp, int options, char *endCommand, char *prompt1, char *prompt2)); #undef TCL_STORAGE_CLASS #define TCL_STORAGE_CLASS DLLIMPORT #endif tclx8.4-8.4.1.orig/generic/tclXselect.c0000644000000000000000000003454212046313170014454 0ustar /* * tclXselect.c * * Select command. This is the generic code associated with the select system * call. It relies on the Unix style select, which operates on bit sets of * file numbers. Platform specific code is called to translate channels into * file numbers, but all operations are generic. On Win32, this only works * on sockets. Ideally, it would push more code into the platform specific * modules and work on more file types. However, right now, I don't see a * good way to do this on Win32. *----------------------------------------------------------------------------- * Copyright 1991-1999 Karl Lehenbauer and Mark Diekhans. * * Permission to use, copy, modify, and distribute this software and its * documentation for any purpose and without fee is hereby granted, provided * that the above copyright notice appear in all copies. Karl Lehenbauer and * Mark Diekhans make no representations about the suitability of this * software for any purpose. It is provided "as is" without express or * implied warranty. *----------------------------------------------------------------------------- * $Id: tclXselect.c,v 1.7 2005/07/27 22:31:15 hobbs Exp $ *----------------------------------------------------------------------------- */ #ifndef NO_SELECT #include "tclExtdInt.h" /* * A few systems (A/UX 2.0) have select but no macros, define em in this case. */ #ifndef FD_SET # define FD_SET(fd,fdset) (fdset)->fds_bits[0] |= (1<<(fd)) # define FD_CLR(fd,fdset) (fdset)->fds_bits[0] &= ~(1<<(fd)) # define FD_ZERO(fdset) (fdset)->fds_bits[0] = 0 # define FD_ISSET(fd,fdset) (((fdset)->fds_bits[0]) & (1<<(fd))) #endif /* * Data kept about a file channel. */ typedef struct { Tcl_Obj *channelIdObj; Tcl_Channel channel; #ifdef WIN32 /* * XXX Not strictly correct, according to TclX's usage of fds, but we * XXX expect noone to really being using select hardcore on Windows */ unsigned int readFd; unsigned int writeFd; #else int readFd; int writeFd; #endif } channelData_t; /* * Prototypes of internal functions. */ static int ParseSelectFileList _ANSI_ARGS_((Tcl_Interp *interp, int chanAccess, Tcl_Obj *handleList, fd_set *fileSetPtr, channelData_t **channelListPtr, int *maxFileIdPtr)); static int FindPendingData _ANSI_ARGS_((int fileDescCnt, channelData_t *channelList, fd_set *fileDescSetPtr)); static Tcl_Obj * ReturnSelectedFileList _ANSI_ARGS_((fd_set *fileDescSetPtr, int fileDescCnt, channelData_t *channelListPtr)); static int TclX_SelectObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); /*----------------------------------------------------------------------------- * ParseSelectFileList -- * * Parse a list of file handles for select. * * Parameters: * o interp - Error messages are returned in the result. * o chanAccess - TCL_READABLE for read direction, TCL_WRITABLE for write * direction or both for both files. * o handleList (I) - The list of file handles to parse, may be empty. * o fileSetPtr - The select fd_set for the parsed handles is * filled in. * o channelListPtr - A pointer to a dynamically allocated list of * the channels that are in the set. If the list is empty, NULL is * returned. * o maxFileIdPtr (I/O) - If a file id greater than the current value is * encountered, it will be set to that file id. * Returns: * The number of files in the list, or -1 if an error occured. * FIX: Should really pass in access and only get channels that are * requested. *----------------------------------------------------------------------------- */ static int ParseSelectFileList (interp, chanAccess, handleList, fileSetPtr, channelListPtr, maxFileIdPtr) Tcl_Interp *interp; int chanAccess; Tcl_Obj *handleList; fd_set *fileSetPtr; channelData_t **channelListPtr; int *maxFileIdPtr; { int handleCnt, idx; Tcl_Obj **handleObjv; channelData_t *channelList; /* * Optimize empty list handling. */ if (TclX_IsNullObj (handleList)) { *channelListPtr = NULL; return 0; } if (Tcl_ListObjGetElements (interp, handleList, &handleCnt, &handleObjv) != TCL_OK) { return -1; } /* * Handle case of an empty list. */ if (handleCnt == 0) { *channelListPtr = NULL; return 0; } channelList = (channelData_t*) ckalloc (sizeof (channelData_t) * handleCnt); for (idx = 0; idx < handleCnt; idx++) { channelList [idx].channelIdObj = handleObjv [idx]; channelList [idx].channel = TclX_GetOpenChannelObj (interp, handleObjv [idx], chanAccess); if (channelList [idx].channel == NULL) goto errorExit; if (chanAccess & TCL_READABLE) { if (TclXOSGetSelectFnum (interp, channelList [idx].channel, TCL_READABLE, &channelList [idx].readFd) != TCL_OK) goto errorExit; FD_SET (channelList [idx].readFd, fileSetPtr); if ((int)channelList [idx].readFd > *maxFileIdPtr) *maxFileIdPtr = (int)channelList [idx].readFd; } else { channelList [idx].readFd = -1; } if (chanAccess & TCL_WRITABLE) { if (TclXOSGetSelectFnum (interp, channelList [idx].channel, TCL_WRITABLE, &channelList [idx].writeFd) != TCL_OK) goto errorExit; FD_SET (channelList [idx].writeFd, fileSetPtr); if ((int)channelList [idx].writeFd > *maxFileIdPtr) *maxFileIdPtr = (int)channelList [idx].writeFd; } else { channelList [idx].writeFd = -1; } } *channelListPtr = channelList; return handleCnt; errorExit: ckfree ((char *) channelList); return -1; } /*----------------------------------------------------------------------------- * FindPendingData -- * * Scan a list of read files to determine if any of them have data pending * in their buffers. * * Parameters: * o fileDescCnt (I) - Number of descriptors in the list. * o channelListPtr (I) - A pointer to a list of the channel data for * the channels to check. * o fileDescSetPtr (I) - A select fd_set with will have a bit set for * every file that has data pending it its buffer. * Returns: * TRUE if any where found that had pending data, FALSE if none were found. *----------------------------------------------------------------------------- */ static int FindPendingData (fileDescCnt, channelList, fileDescSetPtr) int fileDescCnt; channelData_t *channelList; fd_set *fileDescSetPtr; { int idx, found = FALSE; FD_ZERO (fileDescSetPtr); for (idx = 0; idx < fileDescCnt; idx++) { if (Tcl_InputBuffered (channelList [idx].channel)) { FD_SET (channelList [idx].readFd, fileDescSetPtr); found = TRUE; } } return found; } /*----------------------------------------------------------------------------- * ReturnSelectedFileList -- * * Take the resulting file descriptor sets from a select, and the * list of file descritpors and build up a list of Tcl file handles. * * Parameters: * o fileDescSetPtr (I) - The select fd_set. * o fileDescCnt (I) - Number of descriptors in the list. * o channelListPtr (I) - A pointer to a list of the FILE pointers for * files that are in the set. * Returns: * List of file handles. *----------------------------------------------------------------------------- */ static Tcl_Obj * ReturnSelectedFileList (fileDescSetPtr, fileDescCnt, channelList) fd_set *fileDescSetPtr; int fileDescCnt; channelData_t *channelList; { int idx, handleCnt; Tcl_Obj *fileHandleList = Tcl_NewListObj (0, NULL); handleCnt = 0; for (idx = 0; idx < fileDescCnt; idx++) { if (((channelList [idx].readFd >= 0) && FD_ISSET (channelList [idx].readFd, fileDescSetPtr)) || ((channelList [idx].writeFd >= 0) && FD_ISSET (channelList [idx].writeFd, fileDescSetPtr))) { Tcl_ListObjAppendElement (NULL, fileHandleList, channelList [idx].channelIdObj); handleCnt++; } } return fileHandleList; } /*----------------------------------------------------------------------------- * TclX_SelectObjCmd -- * Implements the select TCL command: * select readhandles ?writehandles? ?excepthandles? ?timeout? * * This command is extra smart in the fact that it checks for read data * pending in the stdio buffer first before doing a select. * * Results: * A list in the form: * {readhandles writehandles excepthandles} * or {} it the timeout expired. *----------------------------------------------------------------------------- */ static int TclX_SelectObjCmd (clientData, interp, objc, objv) ClientData clientData; Tcl_Interp *interp; int objc; Tcl_Obj *CONST objv[]; { static int chanAccess [] = {TCL_READABLE, TCL_WRITABLE, 0}; int idx; fd_set fdSets [3], readPendingFDSet; int descCnts [3]; channelData_t *descLists [3]; Tcl_Obj *handleSetList [3]; int numSelected, maxFileId = 0, pending; int result = TCL_ERROR; struct timeval timeoutRec; struct timeval *timeoutRecPtr; if (objc < 2) { return TclX_WrongArgs (interp, objv [0], " readFileIds ?writeFileIds? ?exceptFileIds? ?timeout?"); } /* * Initialize. 0 == read, 1 == write and 2 == exception. */ for (idx = 0; idx < 3; idx++) { FD_ZERO (&fdSets [idx]); descCnts [idx] = 0; descLists [idx] = NULL; } /* * Parse the file handles and set everything up for the select call. */ for (idx = 0; (idx < 3) && (idx < objc - 1); idx++) { descCnts [idx] = ParseSelectFileList (interp, chanAccess [idx], objv [idx + 1], &fdSets [idx], &descLists [idx], &maxFileId); if (descCnts [idx] < 0) goto exitPoint; } /* * Get the time out. Zero is different that not specified. */ timeoutRecPtr = NULL; if ((objc > 4) && !TclX_IsNullObj (objv [4])) { double timeout, seconds, microseconds; if (Tcl_GetDoubleFromObj (interp, objv [4], &timeout) != TCL_OK) goto exitPoint; if (timeout < 0.0) { TclX_AppendObjResult (interp, "timeout must be greater than ", "or equal to zero", (char *) NULL); goto exitPoint; } seconds = floor (timeout); microseconds = (timeout - seconds) * 1000000.0; timeoutRec.tv_sec = (long) seconds; timeoutRec.tv_usec = (long) microseconds; timeoutRecPtr = &timeoutRec; } /* * Check if any data is pending in the read buffers. If there is, * then do the select, but don't block in it. */ pending = FindPendingData (descCnts [0], descLists [0], &readPendingFDSet); if (pending) { timeoutRec.tv_sec = 0; timeoutRec.tv_usec = 0; timeoutRecPtr = &timeoutRec; } /* * All set, do the select. */ numSelected = select (maxFileId + 1, &fdSets [0], &fdSets [1], &fdSets [2], timeoutRecPtr); if (numSelected < 0) { TclX_AppendObjResult (interp, "select error: ", Tcl_PosixError (interp), (char *) NULL); goto exitPoint; } /* * If there is read data pending in the buffers, force the bits to be set * in the read fdSet. */ if (pending) { for (idx = 0; idx < descCnts [0]; idx++) { if (FD_ISSET (descLists [0] [idx].readFd, &readPendingFDSet)) FD_SET (descLists [0] [idx].readFd, &(fdSets [0])); } } /* * Return the result, either a 3 element list, or leave the result * empty if the timeout occured. */ if (numSelected > 0 || pending) { for (idx = 0; idx < 3; idx++) { handleSetList [idx] = ReturnSelectedFileList (&fdSets [idx], descCnts [idx], descLists [idx]); } Tcl_SetObjResult (interp, Tcl_NewListObj (3, handleSetList)); } result = TCL_OK; exitPoint: for (idx = 0; idx < 3; idx++) { if (descLists [idx] != NULL) ckfree ((char *) descLists [idx]); } return result; } #else /* NO_SELECT */ /*----------------------------------------------------------------------------- * TclX_SelectCmd -- * Dummy select command that returns an error for systems that don't * have select. *----------------------------------------------------------------------------- */ static int TclX_SelectObjCmd (clientData, interp, objc, objv) ClientData clientData; Tcl_Interp *interp; int objc; Tcl_Obj *CONST objv[]; { Tcl_AppendResult(interp, Tcl_GetString(objv[0]), " is not available on this OS", (char *) NULL); return TCL_ERROR; } #endif /* NO_SELECT */ /*----------------------------------------------------------------------------- * TclX_SelectInit -- * Initialize the select command. *----------------------------------------------------------------------------- */ void TclX_SelectInit (interp) Tcl_Interp *interp; { Tcl_CreateObjCommand (interp, "select", TclX_SelectObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc*) NULL); } tclx8.4-8.4.1.orig/generic/tclXfilescan.c0000644000000000000000000007301612046313170014760 0ustar /* * tclXfilescan.c -- * * Tcl file scanning: regular expression matching on lines of a file. * Implements awk. *----------------------------------------------------------------------------- * Copyright 1991-1999 Karl Lehenbauer and Mark Diekhans. * * Permission to use, copy, modify, and distribute this software and its * documentation for any purpose and without fee is hereby granted, provided * that the above copyright notice appear in all copies. Karl Lehenbauer and * Mark Diekhans make no representations about the suitability of this * software for any purpose. It is provided "as is" without express or * implied warranty. *----------------------------------------------------------------------------- * $Id: tclXfilescan.c,v 1.4 2005/04/26 20:01:33 hobbs Exp $ *----------------------------------------------------------------------------- */ #include "tclExtdInt.h" /* * A scan context describes a collection of match patterns and commands, * along with a match default command to apply to a file on a scan. */ typedef struct matchDef_t { Tcl_RegExp regExp; Tcl_Obj *regExpObj; Tcl_Obj *command; struct matchDef_t *nextMatchDefPtr; } matchDef_t; typedef struct scanContext_t { matchDef_t *matchListHead; matchDef_t *matchListTail; Tcl_Obj *defaultAction; char contextHandle [16]; Tcl_Channel copyFileChannel; int fileOpen; } scanContext_t; /* * Data kept on a specific scan. */ typedef struct { int storedLine; /* Has the current line been stored in matchInfo? */ scanContext_t *contextPtr; /* Current scan context. */ Tcl_Channel channel; /* The channel being scanned. */ char *line; /* The line from the file. */ Tcl_UniChar *uniLine; /* UniCode (wide) char line. */ int uniLineLen; off_t offset; /* The offset into the file. */ long bytesRead; /* Number of translated bytes read.*/ long lineNum; /* Current scanned line in the file. */ matchDef_t *matchPtr; /* The current match, or NULL for the default. */ } scanData_t; /* * Prototypes of internal functions. */ static void CleanUpContext _ANSI_ARGS_((void_pt scanTablePtr, scanContext_t *contextPtr)); static int ScanContextCreate _ANSI_ARGS_((Tcl_Interp *interp, void_pt scanTablePtr)); static int ScanContextDelete _ANSI_ARGS_((Tcl_Interp *interp, void_pt scanTablePtr, Tcl_Obj *contextHandleObj)); static int ScanContextCopyFile _ANSI_ARGS_((Tcl_Interp *interp, void_pt scanTablePtr, Tcl_Obj *contextHandleObj, Tcl_Obj *fileHandleObj)); static int TclX_ScancontextObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int TclX_ScanmatchObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static void CopyFileCloseHandler _ANSI_ARGS_((ClientData clientData)); static int SetCopyFileObj _ANSI_ARGS_((Tcl_Interp *interp, scanContext_t *contextPtr, Tcl_Obj *fileHandleObj)); static void ClearCopyFile _ANSI_ARGS_((scanContext_t *contextPtr)); static int SetMatchInfoVar _ANSI_ARGS_((Tcl_Interp *interp, scanData_t *scanData)); static int ScanFile _ANSI_ARGS_((Tcl_Interp *interp, scanContext_t *contextPtr, Tcl_Channel channel)); static void ScanFileCloseHandler _ANSI_ARGS_((ClientData clientData)); static int TclX_ScanfileObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static void FileScanCleanUp _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp)); /*----------------------------------------------------------------------------- * CleanUpContext -- * * Release all resources allocated to the specified scan context. Doesn't * free the table entry. *----------------------------------------------------------------------------- */ static void CleanUpContext (scanTablePtr, contextPtr) void_pt scanTablePtr; scanContext_t *contextPtr; { matchDef_t *matchPtr, *oldMatchPtr; for (matchPtr = contextPtr->matchListHead; matchPtr != NULL;) { Tcl_DecrRefCount(matchPtr->regExpObj); if (matchPtr->command != NULL) Tcl_DecrRefCount (matchPtr->command); oldMatchPtr = matchPtr; matchPtr = matchPtr->nextMatchDefPtr; ckfree ((char *) oldMatchPtr); } if (contextPtr->defaultAction != NULL) { Tcl_DecrRefCount (contextPtr->defaultAction); } ClearCopyFile (contextPtr); ckfree ((char *) contextPtr); } /*----------------------------------------------------------------------------- * ScanContextCreate -- * * Create a new scan context, implements the subcommand: * scancontext create *----------------------------------------------------------------------------- */ static int ScanContextCreate (interp, scanTablePtr) Tcl_Interp *interp; void_pt scanTablePtr; { scanContext_t *contextPtr, **tableEntryPtr; contextPtr = (scanContext_t *) ckalloc (sizeof (scanContext_t)); contextPtr->matchListHead = NULL; contextPtr->matchListTail = NULL; contextPtr->defaultAction = NULL; contextPtr->copyFileChannel = NULL; tableEntryPtr = (scanContext_t **) TclX_HandleAlloc (scanTablePtr, contextPtr->contextHandle); *tableEntryPtr = contextPtr; Tcl_SetStringObj (Tcl_GetObjResult (interp), contextPtr->contextHandle, -1); return TCL_OK; } /*----------------------------------------------------------------------------- * ScanContextDelete -- * * Deletes the specified scan context, implements the subcommand: * scancontext delete contexthandle *----------------------------------------------------------------------------- */ static int ScanContextDelete (interp, scanTablePtr, contextHandleObj) Tcl_Interp *interp; void_pt scanTablePtr; Tcl_Obj *contextHandleObj; { scanContext_t **tableEntryPtr; char *contextHandle; contextHandle = Tcl_GetStringFromObj (contextHandleObj, NULL); tableEntryPtr = (scanContext_t **) TclX_HandleXlate (interp, scanTablePtr, contextHandle); if (tableEntryPtr == NULL) return TCL_ERROR; CleanUpContext (scanTablePtr, *tableEntryPtr); TclX_HandleFree (scanTablePtr, tableEntryPtr); return TCL_OK; } /*----------------------------------------------------------------------------- * CopyFileCloseHandler -- * Close handler for the copyfile. Turns off copying to the file. * Parameters: * o clientData (I) - Pointer to the scan context. *----------------------------------------------------------------------------- */ static void CopyFileCloseHandler (clientData) ClientData clientData; { ((scanContext_t *) clientData)->copyFileChannel = NULL; } /*----------------------------------------------------------------------------- * SetCopyFileObj -- * Set the copy file handle for a context. * Parameters: * o interp - The Tcl interpreter, errors are returned in result. * o contextPtr - Pointer to the scan context. * o fileHandleObj - Object containing file handle of the copy file. * Returns: * TCL_OK or TCL_ERROR. *----------------------------------------------------------------------------- */ static int SetCopyFileObj (interp, contextPtr, fileHandleObj) Tcl_Interp *interp; scanContext_t *contextPtr; Tcl_Obj *fileHandleObj; { Tcl_Channel copyFileChannel; copyFileChannel = TclX_GetOpenChannelObj (interp, fileHandleObj, TCL_WRITABLE); if (copyFileChannel == NULL) return TCL_ERROR; /* * Delete the old copyfile and set the new one. */ if (contextPtr->copyFileChannel != NULL) { Tcl_DeleteCloseHandler (contextPtr->copyFileChannel, CopyFileCloseHandler, (ClientData) contextPtr); } Tcl_CreateCloseHandler (copyFileChannel, CopyFileCloseHandler, (ClientData) contextPtr); contextPtr->copyFileChannel = copyFileChannel; return TCL_OK; } /*----------------------------------------------------------------------------- * ClearCopyFile -- * Clear the copy file handle for a context. * Parameters: * o contextPtr (I) - Pointer to the scan context. *----------------------------------------------------------------------------- */ static void ClearCopyFile (contextPtr) scanContext_t *contextPtr; { if (contextPtr->copyFileChannel != NULL) { Tcl_DeleteCloseHandler (contextPtr->copyFileChannel, CopyFileCloseHandler, (ClientData) contextPtr); contextPtr->copyFileChannel = NULL; } } /*----------------------------------------------------------------------------- * ScanContextCopyFile -- * * Access or set the copy file handle for the specified scan context, * implements the subcommand: * scancontext copyfile contexthandle ?filehandle? *----------------------------------------------------------------------------- */ static int ScanContextCopyFile (interp, scanTablePtr, contextHandleObj, fileHandleObj) Tcl_Interp *interp; void_pt scanTablePtr; Tcl_Obj *contextHandleObj; Tcl_Obj *fileHandleObj; { scanContext_t *contextPtr, **tableEntryPtr; char *contextHandle; contextHandle = Tcl_GetStringFromObj (contextHandleObj, NULL); tableEntryPtr = (scanContext_t **) TclX_HandleXlate (interp, scanTablePtr, contextHandle); if (tableEntryPtr == NULL) return TCL_ERROR; contextPtr = *tableEntryPtr; /* * Return the copy file handle if not specified. */ if (fileHandleObj == NULL) { Tcl_SetStringObj (Tcl_GetObjResult (interp), Tcl_GetChannelName (contextPtr->copyFileChannel), -1); return TCL_OK; } return SetCopyFileObj (interp, contextPtr, fileHandleObj); } /*----------------------------------------------------------------------------- * TclX_ScancontextObjCmd -- * * Implements the TCL scancontext Tcl command, which has the following forms: * scancontext create * scancontext delete *----------------------------------------------------------------------------- */ static int TclX_ScancontextObjCmd (clientData, interp, objc, objv) ClientData clientData; Tcl_Interp *interp; int objc; Tcl_Obj *CONST objv[]; { char *command; char *subCommand; if (objc < 2) return TclX_WrongArgs (interp, objv [0], "option ..."); command = Tcl_GetStringFromObj (objv [0], NULL); subCommand = Tcl_GetStringFromObj (objv [1], NULL); /* * Create a new scan context. */ if (STREQU (subCommand, "create")) { if (objc != 2) return TclX_WrongArgs (interp, objv [0], "create"); return ScanContextCreate (interp, (void_pt) clientData); } /* * Delete a scan context. */ if (STREQU (subCommand, "delete")) { if (objc != 3) return TclX_WrongArgs (interp, objv [0], "delete contexthandle"); return ScanContextDelete (interp, (void_pt) clientData, objv [2]); } /* * Access or set the copyfile. */ if (STREQU (subCommand, "copyfile")) { if ((objc < 3) || (objc > 4)) return TclX_WrongArgs (interp, objv [0], "copyfile contexthandle ?filehandle?"); return ScanContextCopyFile (interp, (void_pt) clientData, objv [2], (objc == 4) ? objv [3] : NULL); } TclX_AppendObjResult (interp, "invalid argument, expected one of: ", "\"create\", \"delete\", or \"copyfile\"", (char *) NULL); return TCL_ERROR; } /*----------------------------------------------------------------------------- * TclX_ScanmatchObjCmd -- * * Implements the TCL command: * scanmatch ?-nocase? contexthandle ?regexp? command *----------------------------------------------------------------------------- */ static int TclX_ScanmatchObjCmd (clientData, interp, objc, objv) ClientData clientData; Tcl_Interp *interp; int objc; Tcl_Obj *CONST objv[]; { scanContext_t *contextPtr, **tableEntryPtr; matchDef_t *newmatch; int regExpFlags = TCL_REG_ADVANCED; int firstArg = 1; if (objc < 3) goto argError; if (STREQU (Tcl_GetStringFromObj (objv[1], NULL), "-nocase")) { regExpFlags |= TCL_REG_NOCASE; firstArg = 2; } /* * If firstArg == 2 (-nocase), the both a regular expression and a command * string must be specified, otherwise the regular expression is optional. */ if (((firstArg == 2) && (objc != 5)) || ((firstArg == 1) && (objc > 4))) goto argError; tableEntryPtr = (scanContext_t **) TclX_HandleXlateObj (interp, (void_pt) clientData, objv [firstArg]); if (tableEntryPtr == NULL) return TCL_ERROR; contextPtr = *tableEntryPtr; /* * Handle the default case (no regular expression). */ if (objc == 3) { if (contextPtr->defaultAction) { Tcl_AppendStringsToObj (Tcl_GetObjResult (interp), Tcl_GetStringFromObj (objv[0], NULL), ": default match already specified in this scan context", (char *) NULL); return TCL_ERROR; } Tcl_IncrRefCount (objv [2]); contextPtr->defaultAction = objv [2]; return TCL_OK; } /* * Add a regular expression to the context. */ newmatch = (matchDef_t *) ckalloc(sizeof (matchDef_t)); newmatch->regExp = (Tcl_RegExp) Tcl_GetRegExpFromObj(interp, objv[firstArg + 1], regExpFlags); if (newmatch->regExp == NULL) { ckfree ((char *) newmatch); return TCL_ERROR; } newmatch->regExpObj = objv[firstArg + 1], Tcl_IncrRefCount (newmatch->regExpObj); newmatch->command = objv [firstArg + 2]; Tcl_IncrRefCount (newmatch->command); /* * Link in the new match. */ newmatch->nextMatchDefPtr = NULL; if (contextPtr->matchListHead == NULL) contextPtr->matchListHead = newmatch; else contextPtr->matchListTail->nextMatchDefPtr = newmatch; contextPtr->matchListTail = newmatch; return TCL_OK; argError: return TclX_WrongArgs (interp, objv [0], "?-nocase? contexthandle ?regexp? command"); } /*----------------------------------------------------------------------------- * SetMatchInfoVar -- * * Sets the Tcl array variable "matchInfo" to contain information about the * current match. This function is optimize to store per line information * only once. * * Parameters: * o interp - The Tcl interpreter to set the matchInfo variable in. * Errors are returned in result. * o scanData - Data about the current line being scanned. * been stored. *----------------------------------------------------------------------------- */ static int SetMatchInfoVar (interp, scanData) Tcl_Interp *interp; scanData_t *scanData; { static char *MATCHINFO = "matchInfo"; int idx, start, end; char *value; Tcl_DString valueBuf; char key [32]; Tcl_Obj *valueObjPtr, *indexObjv [2]; Tcl_RegExpInfo regExpInfo; Tcl_DStringInit(&valueBuf); /* * Save information about the current line, if it hasn't been saved. */ if (!scanData->storedLine) { scanData->storedLine = TRUE; Tcl_UnsetVar (interp, MATCHINFO, 0); if (Tcl_SetVar2 (interp, MATCHINFO, "line", scanData->line, TCL_LEAVE_ERR_MSG) == NULL) goto errorExit; valueObjPtr = Tcl_NewLongObj ((long) scanData->offset); if (Tcl_SetVar2Ex(interp, MATCHINFO, "offset", valueObjPtr, TCL_LEAVE_ERR_MSG) == NULL) { Tcl_DecrRefCount (valueObjPtr); goto errorExit; } #if 0 /* * FIX: Don't expose till we decide on semantics: Should it include the * current line? All the pieces are here, include doc and tests, just * disabled. */ valueObjPtr = Tcl_NewLongObj ((long) scanData->bytesRead); if (Tcl_SetObjVar2 (interp, MATCHINFO, "bytesread", valueObjPtr, TCL_LEAVE_ERR_MSG) == NULL) { Tcl_DecrRefCount (valueObjPtr); goto errorExit; } #endif valueObjPtr = Tcl_NewIntObj ((long) scanData->lineNum); if (Tcl_SetVar2Ex(interp, MATCHINFO, "linenum", valueObjPtr, TCL_LEAVE_ERR_MSG) == NULL) { Tcl_DecrRefCount (valueObjPtr); goto errorExit; } if (Tcl_SetVar2 (interp, MATCHINFO, "context", scanData->contextPtr->contextHandle, TCL_LEAVE_ERR_MSG) == NULL) goto errorExit; if (Tcl_SetVar2 (interp, MATCHINFO, "handle", Tcl_GetChannelName (scanData->channel), TCL_LEAVE_ERR_MSG) == NULL) goto errorExit; } if (scanData->contextPtr->copyFileChannel != NULL) { if (Tcl_SetVar2 (interp, MATCHINFO, "copyHandle", Tcl_GetChannelName (scanData->contextPtr->copyFileChannel), TCL_LEAVE_ERR_MSG) == NULL) goto errorExit; } if (scanData->matchPtr == NULL) { goto exitPoint; } Tcl_RegExpGetInfo(scanData->matchPtr->regExp, ®ExpInfo); for (idx = 0; idx < regExpInfo.nsubs; idx++) { start = regExpInfo.matches[idx+1].start; end = regExpInfo.matches[idx+1].end; sprintf (key, "subindex%d", idx); indexObjv [0] = Tcl_NewIntObj (start); if (start < 0) { indexObjv [1] = Tcl_NewIntObj (-1); } else { indexObjv [1] = Tcl_NewIntObj (end-1); } valueObjPtr = Tcl_NewListObj (2, indexObjv); if (Tcl_SetVar2Ex(interp, MATCHINFO, key, valueObjPtr, TCL_LEAVE_ERR_MSG) == NULL) { Tcl_DecrRefCount (valueObjPtr); goto errorExit; } sprintf (key, "submatch%d", idx); Tcl_DStringSetLength(&valueBuf, 0); value = Tcl_UniCharToUtfDString(scanData->uniLine + start, end - start, &valueBuf); valueObjPtr = Tcl_NewStringObj(value, (end - start)); if (Tcl_SetVar2Ex(interp, MATCHINFO, key, valueObjPtr, TCL_LEAVE_ERR_MSG) == NULL) { Tcl_DecrRefCount (valueObjPtr); goto errorExit; } } exitPoint: Tcl_DStringFree(&valueBuf); return TCL_OK; errorExit: Tcl_DStringFree(&valueBuf); return TCL_ERROR; } /*----------------------------------------------------------------------------- * ScanFile -- * * Scan a file given a scancontext. *----------------------------------------------------------------------------- */ static int ScanFile (interp, contextPtr, channel) Tcl_Interp *interp; scanContext_t *contextPtr; Tcl_Channel channel; { Tcl_DString lineBuf, uniLineBuf; int result, matchedAtLeastOne; scanData_t data; int matchStat; if (contextPtr->matchListHead == NULL) { TclX_AppendObjResult (interp, "no patterns in current scan context", (char *) NULL); return TCL_ERROR; } data.storedLine = FALSE; data.contextPtr = contextPtr; data.channel = channel; data.bytesRead = 0; data.lineNum = 0; Tcl_DStringInit (&lineBuf); Tcl_DStringInit (&uniLineBuf); result = TCL_OK; while (TRUE) { if (!contextPtr->fileOpen) goto scanExit; /* Closed by a callback */ data.offset = (off_t) Tcl_Tell (channel); Tcl_DStringSetLength (&lineBuf, 0); if (Tcl_Gets (channel, &lineBuf) < 0) { if (Tcl_Eof (channel) || Tcl_InputBlocked (channel)) goto scanExit; Tcl_SetStringObj (Tcl_GetObjResult (interp), Tcl_PosixError (interp), -1); result = TCL_ERROR; goto scanExit; } data.line = Tcl_DStringValue(&lineBuf); data.bytesRead += (lineBuf.length + 1); /* Include EOLN */ data.lineNum++; data.storedLine = FALSE; /* Convert to UTF to UniCode */ Tcl_DStringSetLength (&uniLineBuf, 0); data.uniLine = Tcl_UtfToUniCharDString(Tcl_DStringValue(&lineBuf), Tcl_DStringLength(&lineBuf), &uniLineBuf); data.uniLineLen = Tcl_DStringLength(&uniLineBuf) / sizeof(Tcl_UniChar); matchedAtLeastOne = FALSE; for (data.matchPtr = contextPtr->matchListHead; data.matchPtr != NULL; data.matchPtr = data.matchPtr->nextMatchDefPtr) { matchStat = Tcl_RegExpExec(interp, data.matchPtr->regExp, Tcl_DStringValue(&lineBuf), Tcl_DStringValue(&lineBuf)); if (matchStat < 0) { result = TCL_ERROR; goto scanExit; } if (matchStat == 0) { continue; /* Try next match pattern */ } matchedAtLeastOne = TRUE; result = SetMatchInfoVar (interp, &data); if (result != TCL_OK) goto scanExit; result = Tcl_EvalObj (interp, data.matchPtr->command); if (result == TCL_ERROR) { Tcl_AddObjErrorInfo (interp, "\n while executing a match command", -1); goto scanExit; } if (result == TCL_CONTINUE) { /* * Don't process any more matches for this line. */ goto matchLineExit; } if ((result == TCL_BREAK) || (result == TCL_RETURN)) { /* * Terminate scan. */ result = TCL_OK; goto scanExit; } } matchLineExit: /* * Process default action if required. */ if ((contextPtr->defaultAction != NULL) && (!matchedAtLeastOne)) { data.matchPtr = NULL; result = SetMatchInfoVar(interp, &data); if (result != TCL_OK) goto scanExit; result = Tcl_EvalObj (interp, contextPtr->defaultAction); if (result == TCL_ERROR) { Tcl_AddObjErrorInfo (interp, "\n while executing a match default command", -1); goto scanExit; } if ((result == TCL_BREAK) || (result == TCL_RETURN)) { /* * Terminate scan. */ result = TCL_OK; goto scanExit; } } if ((contextPtr->copyFileChannel != NULL) && (!matchedAtLeastOne)) { if ((Tcl_Write (contextPtr->copyFileChannel, Tcl_DStringValue(&lineBuf), Tcl_DStringLength(&lineBuf)) < 0) || (TclX_WriteNL (contextPtr->copyFileChannel) < 0)) { Tcl_SetStringObj (Tcl_GetObjResult (interp), Tcl_PosixError (interp), -1); return TCL_ERROR; } } } scanExit: Tcl_DStringFree (&lineBuf); Tcl_DStringFree (&uniLineBuf); if (result == TCL_ERROR) return TCL_ERROR; return TCL_OK; } /*----------------------------------------------------------------------------- * ScanFileCloseHandler -- * Close handler for the file being scanned. Marks it as not open. * Parameters: * o clientData (I) - Pointer to the scan context. *----------------------------------------------------------------------------- */ static void ScanFileCloseHandler (clientData) ClientData clientData; { ((scanContext_t *) clientData)->fileOpen = FALSE; } /*----------------------------------------------------------------------------- * TclX_ScanfileObjCmd -- * * Implements the TCL command: * scanfile ?-copyfile copyhandle? contexthandle filehandle *----------------------------------------------------------------------------- */ static int TclX_ScanfileObjCmd (clientData, interp, objc, objv) ClientData clientData; Tcl_Interp *interp; int objc; Tcl_Obj *CONST objv[]; { scanContext_t *contextPtr, **tableEntryPtr; Tcl_Obj *contextHandleObj, *fileHandleObj, *copyFileHandleObj; Tcl_Channel channel; int status; if ((objc != 3) && (objc != 5)) goto argError; if (objc == 3) { contextHandleObj = objv [1]; fileHandleObj = objv [2]; copyFileHandleObj = NULL; } else { if (!STREQU (Tcl_GetStringFromObj (objv[1], NULL), "-copyfile")) goto argError; copyFileHandleObj = objv [2]; contextHandleObj = objv [3]; fileHandleObj = objv [4]; } tableEntryPtr = (scanContext_t **) TclX_HandleXlateObj (interp, (void_pt) clientData, contextHandleObj); if (tableEntryPtr == NULL) return TCL_ERROR; contextPtr = *tableEntryPtr; channel = TclX_GetOpenChannelObj (interp, fileHandleObj, TCL_READABLE); if (channel == NULL) return TCL_ERROR; if (copyFileHandleObj != NULL) { if (SetCopyFileObj (interp, contextPtr, copyFileHandleObj) == TCL_ERROR) return TCL_ERROR; } /* * Scan the file, protecting it with a close handler. * Watch for case where ScanFile may close the file during scan. * [Bug 1045190] */ contextPtr->fileOpen = TRUE; Tcl_CreateCloseHandler (channel, ScanFileCloseHandler, (ClientData) contextPtr); status = ScanFile(interp, contextPtr, channel); if (contextPtr->fileOpen == TRUE) { Tcl_DeleteCloseHandler(channel, ScanFileCloseHandler, (ClientData) contextPtr); } /* * If we set the copyfile, disassociate it from the context. */ if (copyFileHandleObj != NULL) { ClearCopyFile (contextPtr); } return status; argError: return TclX_WrongArgs (interp, objv [0], "?-copyfile filehandle? contexthandle filehandle"); } /*----------------------------------------------------------------------------- * FileScanCleanUp -- * * Called when the interpreter is deleted to cleanup all filescan * resources *----------------------------------------------------------------------------- */ static void FileScanCleanUp (clientData, interp) ClientData clientData; Tcl_Interp *interp; { scanContext_t **tableEntryPtr; int walkKey; walkKey = -1; while (TRUE) { tableEntryPtr = (scanContext_t **) TclX_HandleWalk ((void_pt) clientData, &walkKey); if (tableEntryPtr == NULL) break; CleanUpContext ((void_pt) clientData, *tableEntryPtr); } TclX_HandleTblRelease ((void_pt) clientData); } /*----------------------------------------------------------------------------- * TclX_FilescanInit -- * * Initialize the TCL file scanning facility.. *----------------------------------------------------------------------------- */ void TclX_FilescanInit (interp) Tcl_Interp *interp; { void_pt scanTablePtr; scanTablePtr = TclX_HandleTblInit ("context", sizeof (scanContext_t *), 10); Tcl_CallWhenDeleted (interp, FileScanCleanUp, (ClientData) scanTablePtr); /* * Initialize the commands. */ Tcl_CreateObjCommand (interp, "scanfile", TclX_ScanfileObjCmd, (ClientData) scanTablePtr, (Tcl_CmdDeleteProc*) NULL); Tcl_CreateObjCommand (interp, "scanmatch", TclX_ScanmatchObjCmd, (ClientData) scanTablePtr, (Tcl_CmdDeleteProc*) NULL); Tcl_CreateObjCommand (interp, "scancontext", TclX_ScancontextObjCmd, (ClientData) scanTablePtr, (Tcl_CmdDeleteProc*) NULL); } tclx8.4-8.4.1.orig/generic/tclXprofile.c0000644000000000000000000010274012046313167014637 0ustar /* * tclXprofile.c -- * * Tcl performance profile monitor. *----------------------------------------------------------------------------- * Copyright 1991-1999 Karl Lehenbauer and Mark Diekhans. * * Permission to use, copy, modify, and distribute this software and its * documentation for any purpose and without fee is hereby granted, provided * that the above copyright notice appear in all copies. Karl Lehenbauer and * Mark Diekhans make no representations about the suitability of this * software for any purpose. It is provided "as is" without express or * implied warranty. *----------------------------------------------------------------------------- * $Id: tclXprofile.c,v 1.4 2009/10/13 19:28:23 kot Exp $ *----------------------------------------------------------------------------- */ #include "tclExtdInt.h" /* * For when the level is not known. */ #define UNKNOWN_LEVEL -1 /* * Stack entry used to keep track of an profiling information for procedures * (and commands in command mode). This stack mirrors the Tcl procedure stack. * A chain of variable scope entries is also kept. This tracks the uplevel * chain kept in the Tcl stack. Unlike the Tcl stack, an entry is also make * for the global context and for the commands when in command mode. We count * the amount of time actually in the procedure, not what it has called. This * is the time it spent on the top of the stack. This is do for both eval * level and variable scope. */ typedef struct profEntry_t { int isProc; /* Procedure, not command. */ int procLevel; /* Procedure level. */ int scopeLevel; /* Varaible scope level. */ int evalLevel; /* Tcl_Eval level. */ clock_t evalRealTime; /* Cumulative real and CPU time */ clock_t evalCpuTime; /* entry was on top of stack. */ clock_t scopeRealTime; /* Cumulative Real and CPU time */ clock_t scopeCpuTime; /* entry's scope was active. */ struct profEntry_t *prevEntryPtr; /* Procedure call stack. */ struct profEntry_t *prevScopePtr; /* Procedure var scope chain. */ char cmdName [1]; /* Command name. MUST BE LAST! */ } profEntry_t; /* * Data keeped on a stack snapshot. */ typedef struct profDataEntry_t { clock_t count; clock_t realTime; clock_t cpuTime; } profDataEntry_t; /* * Client data structure for profile command. This contains all global * profiling information for the interpreter. */ typedef struct profInfo_t { Tcl_Interp *interp; /* Interpreter this is for. */ Tcl_Trace traceHandle; /* Handle to current trace. */ int commandMode; /* Prof all commands? */ int evalMode; /* Use eval stack. */ Command *currentCmdPtr; /* Current command table entry. */ Tcl_CmdProc *savedStrCmdProc; /* Saved string command function */ ClientData savedStrCmdClientData; /* and clientData. */ Tcl_ObjCmdProc *savedObjCmdProc; /* Saved object command function */ ClientData savedObjCmdClientData; /* and clientData. */ int evalLevel; /* Eval level when invoked. */ clock_t realTime; /* Current real and CPU time. */ clock_t cpuTime; clock_t prevRealTime; /* Real and CPU time of previous */ clock_t prevCpuTime; /* trace. */ int updatedTimes; /* Has current times been updated?*/ profEntry_t *stackPtr; /* Proc/command nesting stack. */ int stackSize; /* Size of the stack. */ profEntry_t *scopeChainPtr; /* Variable scope chain. */ Tcl_HashTable profDataTable; /* Cumulative time table, Keyed */ /* by call stack list. */ } profInfo_t; /* * Argument to panic on logic errors. Takes an id number. */ static char *PROF_PANIC = "TclX profile bug id = %d\n"; /* * Prototypes of internal functions. */ static void PushEntry _ANSI_ARGS_((profInfo_t *infoPtr, char *cmdName, int isProc, int procLevel, int scopeLevel, int evalLevel)); static void RecordData _ANSI_ARGS_((profInfo_t *infoPtr, profEntry_t *entryPtr)); static void PopEntry _ANSI_ARGS_((profInfo_t *infoPtr)); static void UpdateTOSTimes _ANSI_ARGS_((profInfo_t *infoPtr)); static Command * ProfCommandEvalSetup _ANSI_ARGS_((profInfo_t *infoPtr, int *isProcPtr)); static void ProfCommandEvalFinishup _ANSI_ARGS_((profInfo_t *infoPtr, int isProc)); static int ProfStrCommandEval _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, CONST84 char **argv)); static int ProfObjCommandEval _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static void ProfTraceRoutine _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int evalLevel, char *command, Tcl_CmdProc *cmdProc, ClientData cmdClientData, int argc, char **argv)); static void CleanDataTable _ANSI_ARGS_((profInfo_t *infoPtr)); static void InitializeProcStack _ANSI_ARGS_((profInfo_t *infoPtr, CallFrame *framePtr)); static void TurnOnProfiling _ANSI_ARGS_((profInfo_t *infoPtr, int commandMode, int evalMode)); static void DeleteProfTrace _ANSI_ARGS_((profInfo_t *infoPtr)); static int TurnOffProfiling _ANSI_ARGS_((Tcl_Interp *interp, profInfo_t *infoPtr, char *varName)); static int TclX_ProfileObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static void ProfMonCleanUp _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp)); /*----------------------------------------------------------------------------- * PushEntry -- * Push a procedure or command entry onto the stack. * * Parameters: * o infoPtr - The global profiling info. * o cmdName The procedure or command name. * o isProc - TRUE if its a proc, FALSE if other command. * o procLevel - The procedure call level that the procedure or command will * execute at. * o scopeLevel - The procedure variable scope level that the commands local * variables are at. * o evalLevel - The eval level the command was executed at. For procedures * this is the level it was called at, since if the procedure's commands * are logged, they will be an the next eval level. Maybe be * UNKNOWN_LEVEL. *----------------------------------------------------------------------------- */ static void PushEntry (infoPtr, cmdName, isProc, procLevel, scopeLevel, evalLevel) profInfo_t *infoPtr; char *cmdName; int isProc; int procLevel; int scopeLevel; int evalLevel; { profEntry_t *entryPtr, *scanPtr; /* * Calculate the size of an entry. One byte for name is in the entry. */ entryPtr = (profEntry_t *) ckalloc (sizeof (profEntry_t) + strlen (cmdName)); /* * Fill it in and push onto the stack. Note that the procedures frame has * not yet been layed down or the procedure body eval execute, so the value * they will be in the procedure is recorded. */ entryPtr->isProc = isProc; entryPtr->procLevel = procLevel; entryPtr->scopeLevel = scopeLevel; entryPtr->evalLevel = evalLevel; entryPtr->evalRealTime = 0; entryPtr->evalCpuTime = 0; entryPtr->scopeRealTime = 0; entryPtr->scopeCpuTime = 0; strcpy (entryPtr->cmdName, cmdName); /* * Push onto the stack and set the variable scope chain. The variable * scope entry is chained to the first entry who's scope is less than ours * if this is a proc or less than or equal to ours if this is a command. */ entryPtr->prevEntryPtr = infoPtr->stackPtr; infoPtr->stackPtr = entryPtr; infoPtr->stackSize++; scanPtr = infoPtr->scopeChainPtr; while ((scanPtr != NULL) && (scanPtr->procLevel > 0) && ((isProc && (scanPtr->scopeLevel >= scopeLevel)) || ((!isProc) && (scanPtr->scopeLevel > scopeLevel)))) { scanPtr = scanPtr->prevScopePtr; /* * Only global level can be NULL. */ if (scanPtr == NULL) panic (PROF_PANIC, 1); } entryPtr->prevScopePtr = scanPtr; infoPtr->scopeChainPtr = entryPtr; } /*----------------------------------------------------------------------------- * RecordData -- * Record an entries times in the data table. * * Parameters: * o infoPtr - The global profiling info. * o entryPtr - The entry to record. *----------------------------------------------------------------------------- */ static void RecordData (infoPtr, entryPtr) profInfo_t *infoPtr; profEntry_t *entryPtr; { int idx, newEntry; profEntry_t *scanPtr; char **stackArgv, *stackListPtr; Tcl_HashEntry *hashEntryPtr; profDataEntry_t *dataEntryPtr; /* * Build up a stack list. Entry [0] is the top of the stack, either the * scope or eval stack is followed, based on the -eval option. If both * scope and command mode are enabled, commands other than the top command * are skipped. */ stackArgv = (char **) ckalloc (sizeof (char *) * infoPtr->stackSize); if (infoPtr->evalMode) { for (idx= 0, scanPtr = entryPtr; scanPtr != NULL; scanPtr = scanPtr->prevEntryPtr) { stackArgv [idx++] = scanPtr->cmdName; } } else { for (idx= 0, scanPtr = entryPtr; scanPtr != NULL; scanPtr = scanPtr->prevScopePtr) { stackArgv [idx++] = scanPtr->cmdName; } } stackListPtr = Tcl_Merge (idx, (CONST84 char **) stackArgv); ckfree ((char *) stackArgv); /* * Check the hash table for this entry, either finding an existing or * creating a new hash entry. */ hashEntryPtr = Tcl_CreateHashEntry (&infoPtr->profDataTable, stackListPtr, &newEntry); ckfree (stackListPtr); /* * Either get the existing entry or create a new one. */ if (newEntry) { dataEntryPtr = (profDataEntry_t *) ckalloc (sizeof (profDataEntry_t)); Tcl_SetHashValue (hashEntryPtr, dataEntryPtr); dataEntryPtr->count = 0; dataEntryPtr->realTime = 0; dataEntryPtr->cpuTime = 0; } else { dataEntryPtr = (profDataEntry_t *) Tcl_GetHashValue (hashEntryPtr); } /* * Increment the cumulative data. */ dataEntryPtr->count++; if (infoPtr->evalMode) { dataEntryPtr->realTime += entryPtr->evalRealTime; dataEntryPtr->cpuTime += entryPtr->evalCpuTime; } else { dataEntryPtr->realTime += entryPtr->scopeRealTime; dataEntryPtr->cpuTime += entryPtr->scopeCpuTime; } } /*----------------------------------------------------------------------------- * PopEntry -- * Pop the procedure entry from the top of the stack and record its * times in the data table. * * Parameters: * o infoPtr - The global profiling info. *----------------------------------------------------------------------------- */ static void PopEntry (infoPtr) profInfo_t *infoPtr; { profEntry_t *entryPtr = infoPtr->stackPtr; RecordData (infoPtr, entryPtr); /* * Remove from the stack, reset the scope chain and free. */ infoPtr->stackPtr = entryPtr->prevEntryPtr; infoPtr->stackSize--; infoPtr->scopeChainPtr = infoPtr->stackPtr; ckfree ((char *) entryPtr); } /*----------------------------------------------------------------------------- * UpdateTOSTimes -- * Update the time spent in the entry on the top of the stack before another * is pushed on top or its poped off. * * Parameters: * o infoPtr - The global profiling info. *----------------------------------------------------------------------------- */ static void UpdateTOSTimes (infoPtr) profInfo_t *infoPtr; { /* * Get the current time if we haven't already. */ if (!infoPtr->updatedTimes) { infoPtr->prevRealTime = infoPtr->realTime; infoPtr->prevCpuTime = infoPtr->cpuTime; TclXOSElapsedTime (&infoPtr->realTime, &infoPtr->cpuTime); infoPtr->updatedTimes = TRUE; } if (infoPtr->stackPtr != NULL) { infoPtr->stackPtr->evalRealTime += infoPtr->realTime - infoPtr->prevRealTime; infoPtr->stackPtr->evalCpuTime += infoPtr->cpuTime - infoPtr->prevCpuTime; } if (infoPtr->scopeChainPtr != NULL) { infoPtr->scopeChainPtr->scopeRealTime += infoPtr->realTime - infoPtr->prevRealTime; infoPtr->scopeChainPtr->scopeCpuTime += infoPtr->cpuTime - infoPtr->prevCpuTime; } } /*----------------------------------------------------------------------------- * ProfCommandEvalSetup -- * Do initial work that is common to both the string and object command * evaluators. * * Returns: * A pointer to the current command table entry. *----------------------------------------------------------------------------- */ static Command * ProfCommandEvalSetup (infoPtr, isProcPtr) profInfo_t *infoPtr; int *isProcPtr; { Interp *iPtr = (Interp *) infoPtr->interp; Command *currentCmdPtr; CallFrame *framePtr; int procLevel, scopeLevel, isProc; Tcl_Obj *fullCmdNamePtr; char *fullCmdName; /* * Restore the command table entry. If the command has modified it, don't * mess with it. */ currentCmdPtr = infoPtr->currentCmdPtr; if (currentCmdPtr->proc == ProfStrCommandEval) currentCmdPtr->proc = infoPtr->savedStrCmdProc; if (currentCmdPtr->clientData == (ClientData) infoPtr) currentCmdPtr->clientData = infoPtr->savedStrCmdClientData; if (currentCmdPtr->objProc == ProfObjCommandEval) currentCmdPtr->objProc = infoPtr->savedObjCmdProc; if (currentCmdPtr->objClientData == (ClientData) infoPtr) currentCmdPtr->objClientData = infoPtr->savedObjCmdClientData; infoPtr->currentCmdPtr = NULL; infoPtr->savedStrCmdProc = NULL; infoPtr->savedStrCmdClientData = NULL; infoPtr->savedObjCmdProc = NULL; infoPtr->savedObjCmdClientData = NULL; fullCmdNamePtr = Tcl_NewObj (); Tcl_GetCommandFullName (infoPtr->interp, (Tcl_Command) currentCmdPtr, fullCmdNamePtr); fullCmdName = Tcl_GetStringFromObj (fullCmdNamePtr, NULL); /* * Determine current proc and var levels. */ procLevel = 0; for (framePtr = iPtr->framePtr; framePtr != NULL; framePtr = framePtr->callerPtr) { procLevel++; } scopeLevel = (iPtr->varFramePtr == NULL) ? 0 : iPtr->varFramePtr->level; /* * If there are entries on the stack that are at a higher proc call level * than we are, we have exited into the initial entries that where pushed * on the stack before we started. Pop those entries. */ if (infoPtr->stackPtr->procLevel > procLevel) UpdateTOSTimes (infoPtr); while (infoPtr->stackPtr->procLevel > procLevel) { if (infoPtr->stackPtr->evalLevel != UNKNOWN_LEVEL) panic (PROF_PANIC, 2); /* Not an initial entry */ PopEntry (infoPtr); } /* * If this command is a procedure or if all commands are being traced, * handle the entry. */ isProc = (TclFindProc (iPtr, fullCmdName) != NULL); if (infoPtr->commandMode || isProc) { UpdateTOSTimes (infoPtr); if (isProc) { PushEntry (infoPtr, fullCmdName, TRUE, procLevel + 1, scopeLevel + 1, infoPtr->evalLevel); } else { PushEntry (infoPtr, fullCmdName, FALSE, procLevel, scopeLevel, infoPtr->evalLevel); } } /* * Leaving profiler, must get time again when we reenter. */ infoPtr->updatedTimes = FALSE; *isProcPtr = isProc; Tcl_DecrRefCount (fullCmdNamePtr); return currentCmdPtr; } /*----------------------------------------------------------------------------- * ProfCommandEvalFinishup -- * Do final work that is common to both the string and object command * evaluators. *----------------------------------------------------------------------------- */ static void ProfCommandEvalFinishup (infoPtr, isProc) profInfo_t *infoPtr; int isProc; { /* * If tracing is still running, pop the entry, recording the information. */ if (infoPtr->traceHandle != NULL) { if (infoPtr->commandMode || isProc) { UpdateTOSTimes (infoPtr); PopEntry (infoPtr); } } /* * Leaving profiler, must get time again when we reenter. */ infoPtr->updatedTimes = FALSE; } /*----------------------------------------------------------------------------- * ProfStrCommandEval -- * Function to evaluate a string command. The procedure trace routine * substitutes this function for the command executor function in the Tcl * command table. We restore the command table, record data about the start * of the command and then actually execute the command. When the command * returns, we record data about the time it took. * * FIX: This all falls apart if another trace is executed between the * doctoring of the command entry and this function being called. *----------------------------------------------------------------------------- */ static int ProfStrCommandEval (clientData, interp, argc, argv) ClientData clientData; Tcl_Interp *interp; int argc; CONST84 char **argv; { profInfo_t *infoPtr = (profInfo_t *) clientData; Command *currentCmdPtr; int isProc, result; currentCmdPtr = ProfCommandEvalSetup (infoPtr, &isProc); result = (*currentCmdPtr->proc) (currentCmdPtr->clientData, interp, argc, argv); ProfCommandEvalFinishup (infoPtr, isProc); return result; } /*----------------------------------------------------------------------------- * ProfObjCommandEval -- * Function to evaluate a object command. The procedure trace routine * substitutes this function for the command executor function in the Tcl * command table. We restore the command table, record data about the start * of the command and then actually execute the command. When the command * returns, we record data about the time it took. * * FIX: This all falls apart if another trace is executed between the * doctoring of the command entry and this function being called. *----------------------------------------------------------------------------- */ static int ProfObjCommandEval (clientData, interp, objc, objv) ClientData clientData; Tcl_Interp *interp; int objc; Tcl_Obj *CONST objv[]; { profInfo_t *infoPtr = (profInfo_t *) clientData; Command *currentCmdPtr; int isProc, result; currentCmdPtr = ProfCommandEvalSetup (infoPtr, &isProc); result = (*currentCmdPtr->objProc) (currentCmdPtr->objClientData, interp, objc, objv); ProfCommandEvalFinishup (infoPtr, isProc); return result; } /*----------------------------------------------------------------------------- * ProfTraceRoutine -- * Routine called by Tcl_Eval to do profiling. It intercepts the current * command being executed by temporarily editing the command table. *----------------------------------------------------------------------------- */ static void ProfTraceRoutine (clientData, interp, evalLevel, command, cmdProc, cmdClientData, argc, argv) ClientData clientData; Tcl_Interp *interp; int evalLevel; char *command; Tcl_CmdProc *cmdProc; ClientData cmdClientData; int argc; char **argv; { profInfo_t *infoPtr = (profInfo_t *) clientData; Command *cmdPtr; Tcl_Command cmd; if (infoPtr->currentCmdPtr != NULL) panic (PROF_PANIC, 3); cmd = Tcl_FindCommand (interp, argv [0], NULL, 0); if (cmd == NULL) panic (PROF_PANIC, 4); cmdPtr = (Command *) cmd; if ((cmdPtr->proc != cmdProc) || (cmdPtr->clientData != cmdClientData)) panic (PROF_PANIC, 5); /* * If command is to be compiled, we can't profile it. */ if (cmdPtr->compileProc != NULL) return; /* * Save current state information. */ infoPtr->currentCmdPtr = cmdPtr; infoPtr->savedStrCmdProc = cmdPtr->proc; infoPtr->savedStrCmdClientData = cmdPtr->clientData; infoPtr->savedObjCmdProc = cmdPtr->objProc; infoPtr->savedObjCmdClientData = cmdPtr->objClientData; infoPtr->evalLevel = evalLevel; /* * Force our routines to be called. */ cmdPtr->proc = ProfStrCommandEval; cmdPtr->clientData = (ClientData) infoPtr; cmdPtr->objProc = ProfObjCommandEval; cmdPtr->objClientData = (ClientData) infoPtr; } /*----------------------------------------------------------------------------- * CleanDataTable -- * Clean up the hash data table, releasing all resources and setting it * to the empty state. * * Parameters: * o infoPtr - The global profiling info. *----------------------------------------------------------------------------- */ static void CleanDataTable (infoPtr) profInfo_t *infoPtr; { Tcl_HashEntry *hashEntryPtr; Tcl_HashSearch searchCookie; hashEntryPtr = Tcl_FirstHashEntry (&infoPtr->profDataTable, &searchCookie); while (hashEntryPtr != NULL) { ckfree ((char *) Tcl_GetHashValue (hashEntryPtr)); Tcl_DeleteHashEntry (hashEntryPtr); hashEntryPtr = Tcl_NextHashEntry (&searchCookie); } } /*----------------------------------------------------------------------------- * InitializeProcStack -- * Recursive procedure to initialize the procedure call stack so its in the * same state as the actual procedure call stack. If commandMode is enable, * command records are still are not initialized on the stack, as we have no * way of knowing what command did a Tcl_Eval. * * Parameters: * o infoPtr - The global profiling info. * o framePtr - Pointer to the frame to push. We recurse down to the bottom, * then push on the way out. *----------------------------------------------------------------------------- */ static void InitializeProcStack (infoPtr, framePtr) profInfo_t *infoPtr; CallFrame *framePtr; { if (framePtr == NULL || framePtr->objv == NULL) return; InitializeProcStack (infoPtr, framePtr->callerPtr); PushEntry (infoPtr, Tcl_GetStringFromObj (framePtr->objv [0], NULL), TRUE, infoPtr->stackPtr->procLevel + 1, framePtr->level, UNKNOWN_LEVEL); } /*----------------------------------------------------------------------------- * TurnOnProfiling -- * Turn on profiling. * * Parameters: * o infoPtr - The global profiling info. * o commandMode - TRUE if all commands are going to be logged, FALSE if just * procs. * o evalMode - TRUE if eval stack is to be used to log entries. FALSE if * the scope stack is to be used. *----------------------------------------------------------------------------- */ static void TurnOnProfiling (infoPtr, commandMode, evalMode) profInfo_t *infoPtr; int commandMode; int evalMode; { Interp *iPtr = (Interp *) infoPtr->interp; int scopeLevel; profEntry_t *scanPtr; CleanDataTable (infoPtr); infoPtr->traceHandle = Tcl_CreateTrace (infoPtr->interp, MAXINT, (Tcl_CmdTraceProc *) ProfTraceRoutine, (ClientData) infoPtr); infoPtr->commandMode = commandMode; infoPtr->evalMode = evalMode; infoPtr->realTime = 0; infoPtr->cpuTime = 0; infoPtr->prevRealTime = 0; infoPtr->prevCpuTime = 0; infoPtr->updatedTimes = FALSE; /* * Add entry for global context, then add in current procedures. */ PushEntry (infoPtr, "", TRUE, 0, 0, 0); InitializeProcStack (infoPtr, ((Interp *) infoPtr->interp)->framePtr); /* * Find the current top of the scope stack. */ scopeLevel = (iPtr->varFramePtr == NULL) ? 0 : iPtr->varFramePtr->level; scanPtr = infoPtr->scopeChainPtr; while ((scanPtr != NULL) && (scanPtr->scopeLevel >= scopeLevel) && (scanPtr->procLevel > 0)) { scanPtr = scanPtr->prevScopePtr; /* * Only global level can be NULL. */ if (scanPtr == NULL) panic (PROF_PANIC, 6); } infoPtr->scopeChainPtr = scanPtr; /* * Get the time we started. */ TclXOSElapsedTime (&infoPtr->realTime, &infoPtr->cpuTime); } /*----------------------------------------------------------------------------- * DeleteProfTrace -- * Delete the profile trace and clean up the stack, logging all procs * as if they had exited. Data table must still be available. * * Parameters: * o infoPtr - The global profiling info. *----------------------------------------------------------------------------- */ static void DeleteProfTrace (infoPtr) profInfo_t *infoPtr; { Tcl_DeleteTrace (infoPtr->interp, infoPtr->traceHandle); infoPtr->traceHandle = NULL; UpdateTOSTimes (infoPtr); while (infoPtr->stackPtr != NULL) { PopEntry (infoPtr); } } /*----------------------------------------------------------------------------- * TurnOffProfiling -- * Turn off profiling. Dump the table data to an array variable. Entries * will be deleted as they are dumped to limit memory utilization. * * Parameters: * o interp - Pointer to the interprer. * o infoPtr - The global profiling info. * o varName - The name of the variable to save the data in. * Returns: * TCL_OK or TCL_ERROR. * FIX: Should take Tcl_Obj for varName. *----------------------------------------------------------------------------- */ static int TurnOffProfiling (interp, infoPtr, varName) Tcl_Interp *interp; profInfo_t *infoPtr; char *varName; { Tcl_HashEntry *hashEntryPtr; Tcl_HashSearch searchCookie; profDataEntry_t *dataEntryPtr; CONST84 char *dataArgv [3]; char countBuf [32], realTimeBuf [32], cpuTimeBuf [32], *dataListPtr; DeleteProfTrace (infoPtr); dataArgv [0] = countBuf; dataArgv [1] = realTimeBuf; dataArgv [2] = cpuTimeBuf; Tcl_UnsetVar (interp, varName, 0); hashEntryPtr = Tcl_FirstHashEntry (&infoPtr->profDataTable, &searchCookie); while (hashEntryPtr != NULL) { dataEntryPtr = (profDataEntry_t *) Tcl_GetHashValue (hashEntryPtr); sprintf (countBuf, "%ld", (long) dataEntryPtr->count); sprintf (realTimeBuf, "%ld", (long) dataEntryPtr->realTime); sprintf (cpuTimeBuf, "%ld", (long) dataEntryPtr->cpuTime); dataListPtr = Tcl_Merge (3, dataArgv); if (Tcl_SetVar2 (interp, varName, Tcl_GetHashKey (&infoPtr->profDataTable, hashEntryPtr), dataListPtr, TCL_LEAVE_ERR_MSG) == NULL) { ckfree (dataListPtr); return TCL_ERROR; } ckfree (dataListPtr); ckfree ((char *) dataEntryPtr); Tcl_DeleteHashEntry (hashEntryPtr); hashEntryPtr = Tcl_NextHashEntry (&searchCookie); } return TCL_OK; } /*----------------------------------------------------------------------------- * TclX_ProfileObjCmd -- * Implements the TCL profile command: * profile ?-commands? ?-eval? on * profile off arrayvar *----------------------------------------------------------------------------- */ static int TclX_ProfileObjCmd (clientData, interp, objc, objv) ClientData clientData; Tcl_Interp *interp; int objc; Tcl_Obj *CONST objv[]; { profInfo_t *infoPtr = (profInfo_t *) clientData; int argIdx; int commandMode = FALSE, evalMode = FALSE; char *argStr; /* * Parse option arguments. */ for (argIdx = 1; argIdx < objc; argIdx++) { argStr = Tcl_GetStringFromObj (objv [argIdx], NULL); if (argStr[0] != '-') break; if (STREQU (argStr, "-commands")) { commandMode = TRUE; } else if (STREQU (argStr, "-eval")) { evalMode = TRUE; } else { TclX_AppendObjResult (interp, "expected one of \"-commands\", or ", "\"-eval\", got \"", argStr, "\"", (char *) NULL); return TCL_ERROR; } } if (argIdx >= objc) goto wrongArgs; /* * Get argument string for remainder of strings. */ argStr = Tcl_GetStringFromObj (objv [argIdx], NULL); /* * Handle the on command. */ if (STREQU (argStr, "on")) { if (argIdx != objc - 1) goto wrongArgs; if (infoPtr->traceHandle != NULL) { TclX_AppendObjResult (interp, "profiling is already enabled", (char *) NULL); return TCL_ERROR; } TurnOnProfiling (infoPtr, commandMode, evalMode); return TCL_OK; } /* * Handle the off command. Dump the hash table to a variable. */ if (STREQU (argStr, "off")) { if (argIdx != objc - 2) goto wrongArgs; if (commandMode || evalMode) { TclX_AppendObjResult (interp, "option \"", commandMode ? "-command" : "-eval", "\" not valid when turning off ", "profiling", (char *) NULL); return TCL_ERROR; } if (infoPtr->traceHandle == NULL) { TclX_AppendObjResult (interp, "profiling is not currently enabled", (char *) NULL); return TCL_ERROR; } if (TurnOffProfiling (interp, infoPtr, Tcl_GetStringFromObj (objv [argIdx + 1], NULL)) != TCL_OK) return TCL_ERROR; return TCL_OK; } /* * Not a valid subcommand. */ TclX_AppendObjResult (interp, "expected one of \"on\" or \"off\", got \"", argStr, "\"", (char *) NULL); return TCL_ERROR; wrongArgs: return TclX_WrongArgs (interp, objv [0], "?-commands? ?-eval? on|off arrayVar"); } /*----------------------------------------------------------------------------- * ProfMonCleanUp -- * Release the client data area when the interpreter is deleted. *----------------------------------------------------------------------------- */ static void ProfMonCleanUp (clientData, interp) ClientData clientData; Tcl_Interp *interp; { profInfo_t *infoPtr = (profInfo_t *) clientData; if (infoPtr->traceHandle != NULL) DeleteProfTrace (infoPtr); CleanDataTable (infoPtr); Tcl_DeleteHashTable (&infoPtr->profDataTable); ckfree ((char *) infoPtr); } /*----------------------------------------------------------------------------- * Tcl_InitProfile -- * Initialize the Tcl profiling command. *----------------------------------------------------------------------------- */ void TclX_ProfileInit (interp) Tcl_Interp *interp; { profInfo_t *infoPtr; infoPtr = (profInfo_t *) ckalloc (sizeof (profInfo_t)); infoPtr->interp = interp; infoPtr->traceHandle = NULL; infoPtr->commandMode = FALSE; infoPtr->evalMode = FALSE; infoPtr->currentCmdPtr = NULL; infoPtr->savedStrCmdProc = NULL; infoPtr->savedStrCmdClientData = NULL; infoPtr->savedObjCmdProc = NULL; infoPtr->savedObjCmdClientData = NULL; infoPtr->evalLevel = UNKNOWN_LEVEL; infoPtr->realTime = 0; infoPtr->cpuTime = 0; infoPtr->prevRealTime = 0; infoPtr->prevCpuTime = 0; infoPtr->updatedTimes = FALSE; infoPtr->stackPtr = NULL; infoPtr->stackSize = 0; infoPtr->scopeChainPtr = NULL; Tcl_InitHashTable (&infoPtr->profDataTable, TCL_STRING_KEYS); Tcl_CallWhenDeleted (interp, ProfMonCleanUp, (ClientData) infoPtr); Tcl_CreateObjCommand (interp, "profile", TclX_ProfileObjCmd, (ClientData) infoPtr, (Tcl_CmdDeleteProc*) NULL); } tclx8.4-8.4.1.orig/generic/tclXhandles.c0000644000000000000000000004535112046313167014621 0ustar /* * * tclXhandles.c -- * * Tcl handles. Provides a mechanism for managing expandable tables that are * addressed by textual handles. *----------------------------------------------------------------------------- * Copyright 1991-1999 Karl Lehenbauer and Mark Diekhans. * * Permission to use, copy, modify, and distribute this software and its * documentation for any purpose and without fee is hereby granted, provided * that the above copyright notice appear in all copies. Karl Lehenbauer and * Mark Diekhans make no representations about the suitability of this * software for any purpose. It is provided "as is" without express or * implied warranty. *----------------------------------------------------------------------------- * $Id: tclXhandles.c,v 1.1 2001/10/24 23:31:48 hobbs Exp $ *----------------------------------------------------------------------------- */ #include "tclExtdInt.h" /* * Variable set to contain the alignment factor (in bytes) for this machine. * It is set on the first table initialization. */ static int entryAlignment = 0; /* * Rounded size of an entry header */ static int entryHeaderSize = 0; /* * Marco to rounded up a size to be a multiple of (void *). This is required * for systems that have alignment restrictions on pointers and data. */ #define ROUND_ENTRY_SIZE(size) \ ((((size) + entryAlignment - 1) / entryAlignment) * entryAlignment) /* * This is the table header. It is separately allocated from the table body, * since it must keep track of a table body that might move. Each entry in the * table is preceded with a header which has the free list link, which is a * entry index of the next free entry. Special values keep track of allocated * entries. */ #define NULL_IDX -1 #define ALLOCATED_IDX -2 typedef unsigned char ubyte_t; typedef ubyte_t *ubyte_pt; typedef struct { int useCount; /* Keeps track of the number sharing */ int entrySize; /* Entry size in bytes, including header */ int tableSize; /* Current number of entries in the table */ int freeHeadIdx; /* Index of first free entry in the table */ ubyte_pt bodyPtr; /* Pointer to table body */ int baseLength; /* Length of handleBase. */ char handleBase [1]; /* Base handle name. MUST BE LAST FIELD! */ } tblHeader_t; typedef tblHeader_t *tblHeader_pt; typedef struct { int freeLink; } entryHeader_t; typedef entryHeader_t *entryHeader_pt; /* * This macro is used to return a pointer to an entry, given its index. */ #define TBL_INDEX(hdrPtr, idx) \ ((entryHeader_pt) (hdrPtr->bodyPtr + (hdrPtr->entrySize * idx))) /* * This macros to convert between pointers to the user and header area of * an table entry. */ #define USER_AREA(entryHdrPtr) \ ((void_pt) (((ubyte_pt) entryHdrPtr) + entryHeaderSize)) #define HEADER_AREA(entryPtr) \ ((entryHeader_pt) (((ubyte_pt) entryPtr) - entryHeaderSize)) /* * Prototypes of internal functions. */ static void LinkInNewEntries _ANSI_ARGS_((tblHeader_pt tblHdrPtr, int newIdx, int numEntries)); static void ExpandTable _ANSI_ARGS_((tblHeader_pt tblHdrPtr, int neededIdx)); static entryHeader_pt AllocEntry _ANSI_ARGS_((tblHeader_pt tblHdrPtr, int *entryIdxPtr)); static int HandleDecodeObj _ANSI_ARGS_((Tcl_Interp *interp, tblHeader_pt tblHdrPtr, CONST char *handle)); static int HandleDecode _ANSI_ARGS_((Tcl_Interp *interp, tblHeader_pt tblHdrPtr, CONST char *handle)); /*============================================================================= * LinkInNewEntries -- * Build free links through the newly allocated part of a table. * * Parameters: * o tblHdrPtr (I) - A pointer to the table header. * o newIdx (I) - Index of the first new entry. * o numEntries (I) - The number of new entries. *----------------------------------------------------------------------------- */ static void LinkInNewEntries (tblHdrPtr, newIdx, numEntries) tblHeader_pt tblHdrPtr; int newIdx; int numEntries; { int entIdx, lastIdx; entryHeader_pt entryHdrPtr; lastIdx = newIdx + numEntries - 1; for (entIdx = newIdx; entIdx < lastIdx; entIdx++) { entryHdrPtr = TBL_INDEX (tblHdrPtr, entIdx); entryHdrPtr->freeLink = entIdx + 1; } entryHdrPtr = TBL_INDEX (tblHdrPtr, lastIdx); entryHdrPtr->freeLink = tblHdrPtr->freeHeadIdx; tblHdrPtr->freeHeadIdx = newIdx; } /*============================================================================= * ExpandTable -- * Expand a handle table, doubling its size. * Parameters: * o tblHdrPtr (I) - A pointer to the table header. * o neededIdx (I) - If positive, then the table will be expanded so that * this entry is available. If -1, then just expand by the number of * entries specified on table creation. MUST be smaller than this size. *----------------------------------------------------------------------------- */ static void ExpandTable (tblHdrPtr, neededIdx) tblHeader_pt tblHdrPtr; int neededIdx; { ubyte_pt oldbodyPtr = tblHdrPtr->bodyPtr; int numNewEntries; int newSize; if (neededIdx < 0) numNewEntries = tblHdrPtr->tableSize; else numNewEntries = (neededIdx - tblHdrPtr->tableSize) + 1; newSize = (tblHdrPtr->tableSize + numNewEntries) * tblHdrPtr->entrySize; tblHdrPtr->bodyPtr = (ubyte_pt) ckalloc (newSize); memcpy (tblHdrPtr->bodyPtr, oldbodyPtr, (tblHdrPtr->tableSize * tblHdrPtr->entrySize)); LinkInNewEntries (tblHdrPtr, tblHdrPtr->tableSize, numNewEntries); tblHdrPtr->tableSize += numNewEntries; ckfree ((char *) oldbodyPtr); } /*============================================================================= * AllocEntry -- * Allocate a table entry, expanding if necessary. * * Parameters: * o tblHdrPtr (I) - A pointer to the table header. * o entryIdxPtr (O) - The index of the table entry is returned here. * Returns: * The a pointer to the entry. *----------------------------------------------------------------------------- */ static entryHeader_pt AllocEntry (tblHdrPtr, entryIdxPtr) tblHeader_pt tblHdrPtr; int *entryIdxPtr; { int entryIdx; entryHeader_pt entryHdrPtr; if (tblHdrPtr->freeHeadIdx == NULL_IDX) ExpandTable (tblHdrPtr, -1); entryIdx = tblHdrPtr->freeHeadIdx; entryHdrPtr = TBL_INDEX (tblHdrPtr, entryIdx); tblHdrPtr->freeHeadIdx = entryHdrPtr->freeLink; entryHdrPtr->freeLink = ALLOCATED_IDX; *entryIdxPtr = entryIdx; return entryHdrPtr; } /*============================================================================= * HandleDecode -- * Decode handle into an entry number. * * Same as HandleDecode except it uses the object-based result * mechanism if an error occurs. * * Parameters: * o interp (I) - A error message may be returned in result. * o tblHdrPtr (I) - A pointer to the table header. * o handle (I) - Handle to decode. * Returns: * The entry index decoded from the handle, or a negative number if an error * occured. *----------------------------------------------------------------------------- */ static int HandleDecode (interp, tblHdrPtr, handle) Tcl_Interp *interp; tblHeader_pt tblHdrPtr; CONST char *handle; { unsigned entryIdx; if ((strncmp (tblHdrPtr->handleBase, (char *) handle, tblHdrPtr->baseLength) != 0) || !TclX_StrToUnsigned (&handle [tblHdrPtr->baseLength], 10, &entryIdx)) { TclX_AppendObjResult (interp, "invalid ", tblHdrPtr->handleBase, " handle \"", handle, "\"", (char *) NULL); return -1; } return entryIdx; } /*============================================================================= * HandleDecodeObj -- * Decode handle into an entry number. * * Same as HandleDecode except it uses the object-based result * mechanism if an error occurs. * * Parameters: * o interp (I) - A error message may be returned in result. * o tblHdrPtr (I) - A pointer to the table header. * o handle (I) - Handle to decode. * Returns: * The entry index decoded from the handle, or a negative number if an error * occured. *----------------------------------------------------------------------------- */ static int HandleDecodeObj (interp, tblHdrPtr, handle) Tcl_Interp *interp; tblHeader_pt tblHdrPtr; CONST char *handle; { unsigned entryIdx; if ((strncmp (tblHdrPtr->handleBase, (char *) handle, tblHdrPtr->baseLength) != 0) || !TclX_StrToUnsigned (&handle [tblHdrPtr->baseLength], 10, &entryIdx)) { TclX_AppendObjResult (interp, "invalid ", tblHdrPtr->handleBase, " handle \"", handle, "\"", (char *) NULL); return -1; } return entryIdx; } /*============================================================================= * TclX_HandleTblInit -- * Create and initialize a Tcl dynamic handle table. The use count on the * table is set to one. * Parameters: * o handleBase(I) - The base name of the handle, the handle will be returned * in the form "baseNN", where NN is the table entry number. * o entrySize (I) - The size of an entry, in bytes. * o initEntries (I) - Initial size of the table, in entries. * Returns: * A pointer to the table header. *----------------------------------------------------------------------------- */ void_pt TclX_HandleTblInit (handleBase, entrySize, initEntries) CONST char *handleBase; int entrySize; int initEntries; { tblHeader_pt tblHdrPtr; int baseLength = strlen ((char *) handleBase); /* * It its not been calculated yet, determine the entry alignment required * for this machine. */ if (entryAlignment == 0) { entryAlignment = sizeof (void *); if (sizeof (long) > entryAlignment) entryAlignment = sizeof (long); if (sizeof (double) > entryAlignment) entryAlignment = sizeof (double); if (sizeof (off_t) > entryAlignment) entryAlignment = sizeof (off_t); entryHeaderSize = ROUND_ENTRY_SIZE (sizeof (entryHeader_t)); } /* * Set up the table entry. */ tblHdrPtr = (tblHeader_pt) ckalloc (sizeof (tblHeader_t) + baseLength + 1); tblHdrPtr->useCount = 1; tblHdrPtr->baseLength = baseLength; strcpy (tblHdrPtr->handleBase, (char *) handleBase); /* * Calculate entry size, including header, rounded up to sizeof (void *). */ tblHdrPtr->entrySize = entryHeaderSize + ROUND_ENTRY_SIZE (entrySize); tblHdrPtr->freeHeadIdx = NULL_IDX; tblHdrPtr->tableSize = initEntries; tblHdrPtr->bodyPtr = (ubyte_pt) ckalloc (initEntries * tblHdrPtr->entrySize); LinkInNewEntries (tblHdrPtr, 0, initEntries); return (void_pt) tblHdrPtr; } /*============================================================================= * TclX_HandleTblUseCount -- * Alter the handle table use count by the specified amount, which can be * positive or negative. Amount may be zero to retrieve the use count. * Parameters: * o headerPtr (I) - Pointer to the table header. * o amount (I) - The amount to alter the use count by. * Returns: * The resulting use count. *----------------------------------------------------------------------------- */ int TclX_HandleTblUseCount (headerPtr, amount) void_pt headerPtr; int amount; { tblHeader_pt tblHdrPtr = (tblHeader_pt)headerPtr; tblHdrPtr->useCount += amount; return tblHdrPtr->useCount; } /*============================================================================= * TclX_HandleTblRelease -- * Decrement the use count on a Tcl dynamic handle table. If the count * goes to zero or negative, then release the table. * * Parameters: * o headerPtr (I) - Pointer to the table header. *----------------------------------------------------------------------------- */ void TclX_HandleTblRelease (headerPtr) void_pt headerPtr; { tblHeader_pt tblHdrPtr = (tblHeader_pt) headerPtr; tblHdrPtr->useCount--; if (tblHdrPtr->useCount <= 0) { ckfree ((char *) tblHdrPtr->bodyPtr); ckfree ((char *) tblHdrPtr); } } /*============================================================================= * TclX_HandleAlloc -- * Allocate an entry and associate a handle with it. * * Parameters: * o headerPtr (I) - A pointer to the table header. * o handlePtr (O) - Buffer to return handle in. It must be big enough to * hold the name. * Returns: * A pointer to the allocated entry (user part). *----------------------------------------------------------------------------- */ void_pt TclX_HandleAlloc (headerPtr, handlePtr) void_pt headerPtr; char *handlePtr; { tblHeader_pt tblHdrPtr = (tblHeader_pt)headerPtr; entryHeader_pt entryHdrPtr; int entryIdx; entryHdrPtr = AllocEntry ((tblHeader_pt) headerPtr, &entryIdx); sprintf (handlePtr, "%s%d", tblHdrPtr->handleBase, entryIdx); return USER_AREA (entryHdrPtr); } /*============================================================================= * TclX_HandleXlate -- * Translate a handle to a entry pointer. * * Parameters: * o interp (I) - A error message may be returned in result. * o headerPtr (I) - A pointer to the table header. * o handle (I) - The handle assigned to the entry. * Returns: * A pointer to the entry, or NULL if an error occured. *----------------------------------------------------------------------------- */ void_pt TclX_HandleXlate (interp, headerPtr, handle) Tcl_Interp *interp; void_pt headerPtr; CONST char *handle; { tblHeader_pt tblHdrPtr = (tblHeader_pt)headerPtr; entryHeader_pt entryHdrPtr; int entryIdx; if ((entryIdx = HandleDecode (interp, tblHdrPtr, handle)) < 0) return NULL; entryHdrPtr = TBL_INDEX (tblHdrPtr, entryIdx); if ((entryIdx >= tblHdrPtr->tableSize) || (entryHdrPtr->freeLink != ALLOCATED_IDX)) { TclX_AppendObjResult (interp, tblHdrPtr->handleBase, " is not open", (char *) NULL); return NULL; } return USER_AREA (entryHdrPtr); } /*============================================================================= * TclX_HandleXlateObj -- * Translate an object containing a handle name to a entry pointer. * * Parameters: * o interp (I) - A error message may be returned in result. * o headerPtr (I) - A pointer to the table header. * o handleObj (I) - The object containing the handle assigned to the entry. * Returns: * A pointer to the entry, or NULL if an error occured. *----------------------------------------------------------------------------- */ void_pt TclX_HandleXlateObj (interp, headerPtr, handleObj) Tcl_Interp *interp; void_pt headerPtr; Tcl_Obj *handleObj; { tblHeader_pt tblHdrPtr = (tblHeader_pt)headerPtr; entryHeader_pt entryHdrPtr; int entryIdx; char *handle; handle = Tcl_GetStringFromObj (handleObj, NULL); if ((entryIdx = HandleDecodeObj (interp, tblHdrPtr, handle)) < 0) return NULL; entryHdrPtr = TBL_INDEX (tblHdrPtr, entryIdx); if ((entryIdx >= tblHdrPtr->tableSize) || (entryHdrPtr->freeLink != ALLOCATED_IDX)) { TclX_AppendObjResult (interp, tblHdrPtr->handleBase, " is not open", (char *) NULL); return NULL; } return USER_AREA (entryHdrPtr); } /*============================================================================= * TclX_HandleWalk -- * Walk through and find every allocated entry in a table. Entries may * be deallocated during a walk, but should not be allocated. * * Parameters: * o headerPtr (I) - A pointer to the table header. * o walkKeyPtr (I/O) - Pointer to a variable to use to keep track of the * place in the table. The variable should be initialized to -1 before * the first call. * Returns: * A pointer to the next allocated entry, or NULL if there are not more. *----------------------------------------------------------------------------- */ void_pt TclX_HandleWalk (headerPtr, walkKeyPtr) void_pt headerPtr; int *walkKeyPtr; { tblHeader_pt tblHdrPtr = (tblHeader_pt)headerPtr; int entryIdx; entryHeader_pt entryHdrPtr; if (*walkKeyPtr == -1) entryIdx = 0; else entryIdx = *walkKeyPtr + 1; while (entryIdx < tblHdrPtr->tableSize) { entryHdrPtr = TBL_INDEX (tblHdrPtr, entryIdx); if (entryHdrPtr->freeLink == ALLOCATED_IDX) { *walkKeyPtr = entryIdx; return USER_AREA (entryHdrPtr); } entryIdx++; } return NULL; } /*============================================================================= * TclX_WalkKeyToHandle -- * Convert a walk key, as returned from a call to Tcl_HandleWalk into a * handle. The Tcl_HandleWalk must have succeeded. * Parameters: * o headerPtr (I) - A pointer to the table header. * o walkKey (I) - The walk key. * o handlePtr (O) - Buffer to return handle in. It must be big enough to * hold the name. *----------------------------------------------------------------------------- */ void TclX_WalkKeyToHandle (headerPtr, walkKey, handlePtr) void_pt headerPtr; int walkKey; char *handlePtr; { tblHeader_pt tblHdrPtr = (tblHeader_pt)headerPtr; sprintf (handlePtr, "%s%d", tblHdrPtr->handleBase, walkKey); } /*============================================================================= * TclX_HandleFree -- * Frees a handle table entry. * * Parameters: * o headerPtr (I) - A pointer to the table header. * o entryPtr (I) - Entry to free. *----------------------------------------------------------------------------- */ void TclX_HandleFree (headerPtr, entryPtr) void_pt headerPtr; void_pt entryPtr; { tblHeader_pt tblHdrPtr = (tblHeader_pt)headerPtr; entryHeader_pt entryHdrPtr; entryHdrPtr = HEADER_AREA (entryPtr); if (entryHdrPtr->freeLink != ALLOCATED_IDX) panic ("Tcl_HandleFree: entry not allocated %x\n", entryHdrPtr); entryHdrPtr->freeLink = tblHdrPtr->freeHeadIdx; tblHdrPtr->freeHeadIdx = (((ubyte_pt) entryHdrPtr) - tblHdrPtr->bodyPtr) / tblHdrPtr->entrySize; } tclx8.4-8.4.1.orig/generic/tclXprocess.c0000644000000000000000000002266712046313167014666 0ustar /* * tclXprocess.c -- * * Tcl command to create and manage processes. *----------------------------------------------------------------------------- * Copyright 1991-1999 Karl Lehenbauer and Mark Diekhans. * * Permission to use, copy, modify, and distribute this software and its * documentation for any purpose and without fee is hereby granted, provided * that the above copyright notice appear in all copies. Karl Lehenbauer and * Mark Diekhans make no representations about the suitability of this * software for any purpose. It is provided "as is" without express or * implied warranty. *----------------------------------------------------------------------------- * $Id: tclXprocess.c,v 1.1 2001/10/24 23:31:48 hobbs Exp $ *----------------------------------------------------------------------------- */ #include "tclExtdInt.h" /* * These are needed for wait command even if waitpid is not available. */ #ifndef WNOHANG # define WNOHANG 1 #endif #ifndef WUNTRACED # define WUNTRACED 2 #endif static int TclX_ExeclObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int TclX_ForkObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int TclX_WaitObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); /*----------------------------------------------------------------------------- * TclX_ForkObjCmd -- * Implements the TclX fork command: * fork *----------------------------------------------------------------------------- */ static int TclX_ForkObjCmd (clientData, interp, objc, objv) ClientData clientData; Tcl_Interp *interp; int objc; Tcl_Obj *CONST objv[]; { if (objc != 1) return TclX_WrongArgs (interp, objv [0], ""); return TclXOSfork (interp, objv [0]); } /*----------------------------------------------------------------------------- * TclX_ExeclObjCmd -- * Implements the TCL execl command: * execl ?-argv0 ? prog ?argList? *----------------------------------------------------------------------------- */ static int TclX_ExeclObjCmd (clientData, interp, objc, objv) ClientData clientData; Tcl_Interp *interp; int objc; Tcl_Obj *CONST objv[]; { #define STATIC_ARG_SIZE 12 char *staticArgv [STATIC_ARG_SIZE]; char **argList = staticArgv; int nextArg = 1; char *argStr; int argObjc; Tcl_Obj **argObjv; char *path, *argv0 = NULL; int idx, status; Tcl_DString pathBuf; status = TCL_ERROR; /* assume the worst */ if (objc < 2) goto wrongArgs; argStr = Tcl_GetStringFromObj (objv [nextArg], NULL); if (STREQU (argStr, "-argv0")) { nextArg++; if (nextArg == objc) goto wrongArgs; argv0 = Tcl_GetStringFromObj (objv [nextArg++], NULL); } if ((nextArg == objc) || (nextArg < objc - 2)) goto wrongArgs; /* * Get path or command name. */ Tcl_DStringInit (&pathBuf); path = Tcl_TranslateFileName (interp, Tcl_GetStringFromObj (objv [nextArg++], NULL), &pathBuf); if (path == NULL) goto exitPoint; /* * If arg list is supplied, split it and build up the arguments to pass. * otherwise, just supply argv[0]. Must be NULL terminated. */ if (nextArg == objc) { argList [1] = NULL; } else { if (Tcl_ListObjGetElements (interp, objv [nextArg++], &argObjc, &argObjv) != TCL_OK) goto exitPoint; if (argObjc > STATIC_ARG_SIZE - 2) argList = (char **) ckalloc ((argObjc + 1) * sizeof (char **)); for (idx = 0; idx < argObjc; idx++) { argList [idx + 1] = Tcl_GetStringFromObj (argObjv [idx], NULL); } argList [argObjc + 1] = NULL; } if (argv0 != NULL) { argList [0] = argv0; } else { argList [0] = path; /* Program name */ } status = TclXOSexecl (interp, path, argList); exitPoint: if (argList != staticArgv) ckfree ((char *) argList); Tcl_DStringFree (&pathBuf); return status; wrongArgs: TclX_WrongArgs (interp, objv [0], "?-argv0 argv0? prog ?argList?"); return TCL_ERROR; } /*----------------------------------------------------------------------------- * TclX_WaitObjCmd -- * Implements the TCL wait command: * wait ?-nohang? ?-untraced? ?-pgroup? ?pid? *----------------------------------------------------------------------------- */ static int TclX_WaitObjCmd (clientData, interp, objc, objv) ClientData clientData; Tcl_Interp *interp; int objc; Tcl_Obj *CONST objv[]; { int idx, options = 0, pgroup = FALSE; char *argStr; pid_t returnedPid, pid; int tmpPid, status; Tcl_Obj *resultList [3]; for (idx = 1; idx < objc; idx++) { argStr = Tcl_GetStringFromObj (objv [idx], NULL); if (argStr [0] != '-') break; if (STREQU (argStr, "-nohang")) { if (options & WNOHANG) goto usage; options |= WNOHANG; continue; } if (STREQU (argStr, "-untraced")) { if (options & WUNTRACED) goto usage; options |= WUNTRACED; continue; } if (STREQU (argStr, "-pgroup")) { if (pgroup) goto usage; pgroup = TRUE; continue; } goto usage; /* None match */ } /* * Check for more than one non-minus argument. If ok, convert pid, * if supplied. */ if (idx < objc - 1) goto usage; if (idx < objc) { if (Tcl_GetIntFromObj (interp, objv [idx], &tmpPid) != TCL_OK) { Tcl_ResetResult (interp); goto invalidPid; } if (tmpPid <= 0) goto negativePid; pid = tmpPid; if (pid != tmpPid) goto invalidPid; } else { pid = -1; /* pid or pgroup not supplied */ } /* * Versions that don't have real waitpid have limited functionality. */ #ifdef NO_WAITPID if ((options != 0) || pgroup) { TclX_AppendObjResult (interp, "The \"-nohang\", \"-untraced\" and ", "\"-pgroup\" options are not available on this ", "system", (char *) NULL); return TCL_ERROR; } #endif if (pgroup) { if (pid > 0) pid = -pid; else pid = 0; } returnedPid = (pid_t) TCLX_WAITPID (pid, (int *) (&status), options); if (returnedPid < 0) { TclX_AppendObjResult (interp, "wait for process failed: ", Tcl_PosixError (interp), (char *) NULL); return TCL_ERROR; } /* * If no process was available, return an empty status. Otherwise return * a list contain the PID and why it stopped. */ if (returnedPid == 0) return TCL_OK; resultList [0] = Tcl_NewIntObj (returnedPid); if (WIFEXITED (status)) { resultList [1] = Tcl_NewStringObj ("EXIT", -1); resultList [2] = Tcl_NewIntObj (WEXITSTATUS (status)); } else if (WIFSIGNALED (status)) { resultList [1] = Tcl_NewStringObj ("SIG", -1); resultList [2] = Tcl_NewStringObj (Tcl_SignalId (WTERMSIG (status)), -1); } else if (WIFSTOPPED (status)) { resultList [1] = Tcl_NewStringObj ("STOP", -1); resultList [2] = Tcl_NewStringObj (Tcl_SignalId (WSTOPSIG (status)), -1); } Tcl_SetListObj (Tcl_GetObjResult (interp), 3, resultList); return TCL_OK; usage: TclX_WrongArgs (interp, objv [0], "?-nohang? ?-untraced? ?-pgroup? ?pid?"); return TCL_ERROR; invalidPid: TclX_AppendObjResult (interp, "invalid pid or process group id \"", Tcl_GetStringFromObj (objv [idx], NULL), "\"", (char *) NULL); return TCL_ERROR; negativePid: TclX_AppendObjResult (interp, "pid or process group id must be greater ", "than zero", (char *) NULL); return TCL_ERROR; } /*----------------------------------------------------------------------------- * TclX_ProcessInit -- * Initialize process commands. *----------------------------------------------------------------------------- */ void TclX_ProcessInit (interp) Tcl_Interp *interp; { Tcl_CreateObjCommand (interp, "execl", TclX_ExeclObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc*) NULL); /* Avoid conflict with "expect". */ TclX_CreateObjCommand (interp, "fork", TclX_ForkObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc*) NULL, 0); TclX_CreateObjCommand (interp, "wait", TclX_WaitObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc*) NULL, 0); } tclx8.4-8.4.1.orig/generic/tclExtdInt.h0000644000000000000000000004333612046313170014432 0ustar /* * tclExtdInt.h * * Standard internal include file for Extended Tcl. *----------------------------------------------------------------------------- * Copyright 1991-1999 Karl Lehenbauer and Mark Diekhans. * * Permission to use, copy, modify, and distribute this software and its * documentation for any purpose and without fee is hereby granted, provided * that the above copyright notice appear in all copies. Karl Lehenbauer and * Mark Diekhans make no representations about the suitability of this * software for any purpose. It is provided "as is" without express or * implied warranty. *----------------------------------------------------------------------------- * $Id: tclExtdInt.h,v 1.8 2008/12/15 20:00:27 andreas_kupries Exp $ *----------------------------------------------------------------------------- */ #ifndef TCLEXTDINT_H #define TCLEXTDINT_H #include "tclExtend.h" /* Keep it before tcl*Port, otherwise a clash in TclpPanic. */ #include "tclInt.h" #if defined(__WIN32__) || defined(_WIN32) # include "tclXwinPort.h" #else # include "tclXunixPort.h" #endif /* * Internal interp flags compatibility - removed in Tcl 8.5 sources. */ #ifndef ERR_IN_PROGRESS #define ERR_IN_PROGRESS 2 #endif #ifndef ERROR_CODE_SET #define ERROR_CODE_SET 8 #endif /* * Assert macro for use in TclX. Some GCCs libraries are missing a function * used by their macro, so we define our own. */ #ifdef TCLX_DEBUG # define TclX_Assert(expr) ((expr) ? (void)0 : \ panic("TclX assertion failure: %s:%d \"%s\"\n",\ __FILE__, __LINE__, "expr")) #else # define TclX_Assert(expr) #endif /* * Get ranges of integers and longs. * If no MAXLONG, assume sizeof (long) == sizeof (int). */ #ifndef MAXINT # ifdef INT_MAX /* POSIX */ # define MAXINT INT_MAX # else # define BITSPERBYTE 8 # define BITS(type) (BITSPERBYTE * (int)sizeof(type)) # define HIBITI (1 << BITS(int) - 1) # define MAXINT (~HIBITI) # endif #endif #ifndef MININT # ifdef INT_MIN /* POSIX */ # define MININT INT_MIN # else # define MININT (-MAXINT)-1 # endif #endif #ifndef MAXLONG # ifdef LONG_MAX /* POSIX */ # define MAXLONG LONG_MAX # else # define MAXLONG MAXINT # endif #endif /* * Boolean constants. */ #ifndef TRUE # define TRUE (1) # define FALSE (0) #endif /* * Defines used by TclX_Get/SetChannelOption. Defines name TCLX_COPT_ are the * options and the others are the value */ #define TCLX_COPT_BLOCKING 1 #define TCLX_MODE_BLOCKING 0 #define TCLX_MODE_NONBLOCKING 1 #define TCLX_COPT_BUFFERING 2 #define TCLX_BUFFERING_FULL 0 #define TCLX_BUFFERING_LINE 1 #define TCLX_BUFFERING_NONE 2 /* * Two values are always returned for translation, one for the read side and * one for the write. They are returned masked into one word. */ #define TCLX_COPT_TRANSLATION 3 #define TCLX_TRANSLATE_READ_SHIFT 8 #define TCLX_TRANSLATE_READ_MASK 0xFF00 #define TCLX_TRANSLATE_WRITE_MASK 0x00FF #define TCLX_TRANSLATE_UNSPECIFIED 0 /* For only one direction specified */ #define TCLX_TRANSLATE_AUTO 1 #define TCLX_TRANSLATE_LF 2 #define TCLX_TRANSLATE_BINARY 2 /* same as LF */ #define TCLX_TRANSLATE_CR 3 #define TCLX_TRANSLATE_CRLF 4 #define TCLX_TRANSLATE_PLATFORM 5 /* * Flags used by chown/chgrp. */ #define TCLX_CHOWN 0x1 #define TCLX_CHGRP 0x2 /* * Structure use to pass file locking information. Parallels the Posix * struct flock, but use to pass info from the generic code to the system * dependent code. */ typedef struct { Tcl_Channel channel; /* Channel to lock */ int access; /* TCL_READABLE and/or TCL_WRITABLE */ int block; /* Block if lock is not available */ off_t start; /* Starting offset */ off_t len; /* len = 0 means until end of file */ pid_t pid; /* Lock owner */ short whence; /* Type of start */ int gotLock; /* Succeeded? */ } TclX_FlockInfo; /* * Used to return argument messages by most commands. * FIX: Should be internal, got thought TclX_WrongArgs. */ extern char *tclXWrongArgs; extern Tcl_Obj *tclXWrongArgsObj; /* * Macros to do string compares. They pre-check the first character before * checking of the strings are equal. */ #define STREQU(str1, str2) \ (((str1)[0] == (str2)[0]) && (strcmp(str1, str2) == 0)) #define STRNEQU(str1, str2, cnt) \ (((str1)[0] == (str2)[0]) && (strncmp(str1, str2, cnt) == 0)) #define OBJSTREQU(obj1, str1) \ (strcmp(Tcl_GetStringFromObj(obj1, NULL), str1) == 0) #define OBJSTRNEQU(obj1, str1, cnt) \ (strncmp(Tcl_GetStringFromObj(obj1, NULL), str1, cnt) == 0) /* * Macro to do ctype functions with 8 bit character sets. */ #define ISSPACE(c) (isspace ((unsigned char) c)) #define ISDIGIT(c) (isdigit ((unsigned char) c)) #define ISLOWER(c) (islower ((unsigned char) c)) /* * Macro that behaves like strdup, only uses ckalloc. Also macro that does the * same with a string that might contain zero bytes, */ #define ckstrdup(sourceStr) \ (strcpy (ckalloc (strlen (sourceStr) + 1), sourceStr)) #define ckbinstrdup(sourceStr, length) \ ((char *) memcpy (ckalloc (length + 1), sourceStr, length + 1)) /* * Handle hiding of errorLine in 8.6 */ #if (TCL_MAJOR_VERSION == 8) && (TCL_MINOR_VERSION < 6) #define ERRORLINE(interp) ((interp)->errorLine) #else #define ERRORLINE(interp) (Tcl_GetErrorLine(interp)) #endif /* * Callback type for walking directories. */ typedef int (TclX_WalkDirProc) _ANSI_ARGS_((Tcl_Interp *interp, char *path, char *fileName, int caseSensitive, ClientData clientData)); /* * Prototypes for utility procedures. */ extern int TclX_CreateObjCommand _ANSI_ARGS_((Tcl_Interp* interp, char* cmdName, Tcl_ObjCmdProc *proc, ClientData clientData, Tcl_CmdDeleteProc *deleteProc, int flags)); extern void * TclX_StructOffset _ANSI_ARGS_((void *nsPtr, size_t offset, unsigned int offType)); /* * Macro to use to fill in "offset" fields of a structure. * Computes number of bytes from beginning of structure to a given field. * Based off Tk_Offset */ #ifdef offsetof #define TclX_Offset(type, field) ((size_t) offsetof(type, field)) #else #define TclX_Offset(type, field) ((size_t) ((char *) &((type *) 0)->field)) #endif /* Special flags for "TclX_CreateObjCommand". */ #define TCLX_CMD_NOPREFIX 1 /* don't define with "exp_" prefix */ #define TCLX_CMD_REDEFINE 2 /* stomp on old commands with same name */ /* * UTF-8 compatibility handling */ #ifndef TCL_UTF_MAX #define Tcl_WriteChars Tcl_Write #endif #define TclX_WriteNL(channel) (Tcl_Write (channel, "\n", 1)) extern int TclX_StrToOffset _ANSI_ARGS_((CONST char *string, int base, off_t *offsetPtr)); int TclX_GetUnsignedFromObj _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr, unsigned *valuePtr)); extern int TclX_GetChannelOption _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Channel channel, int option, int *valuePtr)); extern Tcl_Obj * TclXGetHostInfo _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Channel channel, int remoteHost)); extern Tcl_Channel TclX_GetOpenChannel _ANSI_ARGS_((Tcl_Interp *interp, char *handle, int chanAccess)); extern Tcl_Channel TclX_GetOpenChannelObj _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *handle, int chanAccess)); extern int TclX_GetOffsetFromObj _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr, off_t *offsetPtr)); extern int TclX_RelativeExpr _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *exprPtr, int stringLen, int *exprResultPtr)); extern int TclX_SetChannelOption _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Channel channel, int option, int value)); extern char * TclX_JoinPath _ANSI_ARGS_((char *path1, char *path2, Tcl_DString *joinedPath)); extern int TclX_WrongArgs _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *commandNameObj, char *string)); extern int TclX_IsNullObj _ANSI_ARGS_((Tcl_Obj *objPtr)); /* * Definitions required to initialize all extended commands. */ extern void TclX_BsearchInit _ANSI_ARGS_((Tcl_Interp *interp)); extern void TclX_ChmodInit _ANSI_ARGS_((Tcl_Interp *interp)); extern void TclX_CmdloopInit _ANSI_ARGS_((Tcl_Interp *interp)); extern void TclX_DebugInit _ANSI_ARGS_((Tcl_Interp *interp)); extern void TclX_DupInit _ANSI_ARGS_((Tcl_Interp *interp)); extern void TclX_FcntlInit _ANSI_ARGS_((Tcl_Interp *interp)); extern void TclX_FilecmdsInit _ANSI_ARGS_((Tcl_Interp *interp)); extern void TclX_FstatInit _ANSI_ARGS_((Tcl_Interp *interp)); extern void TclX_FlockInit _ANSI_ARGS_((Tcl_Interp *interp)); extern void TclX_FilescanInit _ANSI_ARGS_((Tcl_Interp *interp)); extern void TclX_GeneralInit _ANSI_ARGS_((Tcl_Interp *interp)); extern void TclX_IdInit _ANSI_ARGS_((Tcl_Interp *interp)); extern void TclX_KeyedListInit _ANSI_ARGS_((Tcl_Interp *interp)); extern void TclX_LgetsInit _ANSI_ARGS_((Tcl_Interp *interp)); extern void TclX_ListInit _ANSI_ARGS_((Tcl_Interp *interp)); extern void TclX_MathInit _ANSI_ARGS_((Tcl_Interp *interp)); extern void TclX_MsgCatInit _ANSI_ARGS_((Tcl_Interp *interp)); extern void TclX_ProcessInit _ANSI_ARGS_((Tcl_Interp *interp)); void TclX_ProfileInit _ANSI_ARGS_((Tcl_Interp *interp)); extern void TclX_RestoreResultErrorInfo _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *saveObjPtr)); extern Tcl_Obj * TclX_SaveResultErrorInfo _ANSI_ARGS_((Tcl_Interp *interp)); extern void TclX_SelectInit _ANSI_ARGS_((Tcl_Interp *interp)); extern void TclX_SignalInit _ANSI_ARGS_((Tcl_Interp *interp)); extern void TclX_StringInit _ANSI_ARGS_((Tcl_Interp *interp)); extern int TclX_LibraryInit _ANSI_ARGS_((Tcl_Interp *interp)); extern void TclX_SocketInit _ANSI_ARGS_((Tcl_Interp *interp)); extern void TclX_OsCmdsInit _ANSI_ARGS_((Tcl_Interp *interp)); extern void TclX_PlatformCmdsInit _ANSI_ARGS_((Tcl_Interp *interp)); extern void TclX_ServerInit _ANSI_ARGS_((Tcl_Interp *interp)); /* * From TclXxxxDup.c */ Tcl_Channel TclXOSDupChannel _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Channel srcChannel, int mode, char *targetChannelId)); Tcl_Channel TclXOSBindOpenFile _ANSI_ARGS_((Tcl_Interp *interp, int fileNum)); /* * from tclXxxxOS.c */ extern int TclXNotAvailableError _ANSI_ARGS_((Tcl_Interp *interp, char *funcName)); extern int TclXNotAvailableObjError _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *obj)); extern clock_t TclXOSTicksToMS _ANSI_ARGS_((clock_t numTicks)); extern int TclXOSgetpriority _ANSI_ARGS_((Tcl_Interp *interp, int *priority, char *funcName)); extern int TclXOSincrpriority _ANSI_ARGS_((Tcl_Interp *interp, int priorityIncr, int *priority, char *funcName)); extern int TclXOSpipe _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Channel *channels)); extern int TclXOSsetitimer _ANSI_ARGS_((Tcl_Interp *interp, double *seconds, char *funcName)); extern void TclXOSsleep _ANSI_ARGS_((unsigned seconds)); extern void TclXOSsync _ANSI_ARGS_((void)); extern int TclXOSfsync _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Channel channel)); extern int TclXOSsystem _ANSI_ARGS_((Tcl_Interp *interp, char *command, int *exitCode)); extern int TclX_OSlink _ANSI_ARGS_((Tcl_Interp *interp, char *srcPath, char *destPath, char *funcName)); extern int TclX_OSsymlink _ANSI_ARGS_((Tcl_Interp *interp, char *srcPath, char *destPath, char *funcName)); extern void TclXOSElapsedTime _ANSI_ARGS_((clock_t *realTime, clock_t *cpuTime)); extern int TclXOSkill _ANSI_ARGS_((Tcl_Interp *interp, pid_t pid, int signal, char *funcName)); extern int TclXOSFstat _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Channel channel, struct stat *statBuf, int *ttyDev)); extern int TclXOSSeekable _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Channel channel, int *seekablePtr)); extern int TclXOSWalkDir _ANSI_ARGS_((Tcl_Interp *interp, char *path, int hidden, TclX_WalkDirProc *callback, ClientData clientData)); extern int TclXOSGetFileSize _ANSI_ARGS_((Tcl_Channel channel, off_t *fileSize)); extern int TclXOSftruncate _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Channel channel, off_t newSize, char *funcName)); extern int TclXOSfork _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *funcNameObj)); extern int TclXOSexecl _ANSI_ARGS_((Tcl_Interp *interp, char *path, char **argList)); extern int TclXOSInetAtoN _ANSI_ARGS_((Tcl_Interp *interp, char *strAddress, struct in_addr *inAddress)); extern int TclXOSgetpeername _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Channel channel, void *sockaddr, int sockaddrSize)); extern int TclXOSgetsockname _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Channel channel, void *sockaddr, int sockaddrSize)); extern int TclXOSgetsockopt _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Channel channel, int option, int *valuePtr)); extern int TclXOSsetsockopt _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Channel channel, int option, int value)); extern int TclXOSchmod _ANSI_ARGS_((Tcl_Interp *interp, char *fileName, int mode)); extern int TclXOSfchmod _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Channel channel, int mode, char *funcName)); extern int TclXOSChangeOwnGrpObj _ANSI_ARGS_((Tcl_Interp *interp, unsigned options, char *ownerStr, char *groupStr, Tcl_Obj *fileList, char *funcName)); extern int TclXOSFChangeOwnGrpObj _ANSI_ARGS_((Tcl_Interp *interp, unsigned options, char *ownerStr, char *groupStr, Tcl_Obj *channelIdList, char *funcName)); int TclXOSGetSelectFnum _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Channel channel, int direction, int *fnumPtr)); int TclXOSHaveFlock _ANSI_ARGS_((void)); int TclXOSFlock _ANSI_ARGS_((Tcl_Interp *interp, TclX_FlockInfo *lockInfoPtr)); int TclXOSFunlock _ANSI_ARGS_((Tcl_Interp *interp, TclX_FlockInfo *lockInfoPtr)); int TclXOSGetAppend _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Channel channel, int *valuePtr)); int TclXOSSetAppend _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Channel channel, int value)); int TclXOSGetCloseOnExec _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Channel channel, int *valuePtr)); int TclXOSSetCloseOnExec _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Channel channel, int value)); #endif tclx8.4-8.4.1.orig/generic/tclXchmod.c0000644000000000000000000003671012046313167014274 0ustar /* * tclXchmod.c -- * * Chmod, chown and chgrp Tcl commands. *----------------------------------------------------------------------------- * Copyright 1991-1999 Karl Lehenbauer and Mark Diekhans. * * Permission to use, copy, modify, and distribute this software and its * documentation for any purpose and without fee is hereby granted, provided * that the above copyright notice appear in all copies. Karl Lehenbauer and * Mark Diekhans make no representations about the suitability of this * software for any purpose. It is provided "as is" without express or * implied warranty. *----------------------------------------------------------------------------- * $Id: tclXchmod.c,v 1.1 2001/10/24 23:31:48 hobbs Exp $ *----------------------------------------------------------------------------- */ #include "tclExtdInt.h" /* * Type used for returning parsed mode informtion. */ typedef struct { char *symMode; /* Symbolic mode. If NULL, use absolute mode. */ int absMode; /* Numeric mode. */ } modeInfo_t; static char *FILE_ID_OPT = "-fileid"; /* * Prototypes of internal functions. */ static int ConvSymMode _ANSI_ARGS_((Tcl_Interp *interp, char *symMode, int modeVal)); static int TclX_ChmodObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int TclX_ChownObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int TclX_ChgrpObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); /*----------------------------------------------------------------------------- * ConvSymMode -- * Parse and convert symbolic file permissions as specified by chmod(C). * * Parameters: * o interp - Pointer to the current interpreter, error messages will be * returned in the result. * o symMode - The symbolic permissions to parse. * o modeVal - The existing permissions value on a file. * * Returns: * The new permissions, or -1 if invalid permissions where supplied. *----------------------------------------------------------------------------- */ static int ConvSymMode (interp, symMode, modeVal) Tcl_Interp *interp; char *symMode; int modeVal; { int user, group, other; char operator, *scanPtr; int rwxMask, ugoMask, setUID, sticky, locking; int newMode; scanPtr = symMode; while (*scanPtr != '\0') { user = group = other = FALSE; /* * Scan who field. */ while (! ((*scanPtr == '+') || (*scanPtr == '-') || (*scanPtr == '='))) { switch (*scanPtr) { case 'a': user = group = other = TRUE; break; case 'u': user = TRUE; break; case 'g': group = TRUE; break; case 'o': other = TRUE; break; default: goto invalidMode; } scanPtr++; } /* * If none where specified, that means all. */ if (! (user || group || other)) user = group = other = TRUE; operator = *scanPtr++; /* * Decode the permissions */ rwxMask = 0; setUID = sticky = locking = FALSE; /* * Scan permissions field */ while (! ((*scanPtr == ',') || (*scanPtr == 0))) { switch (*scanPtr) { case 'r': rwxMask |= 4; break; case 'w': rwxMask |= 2; break; case 'x': rwxMask |= 1; break; case 's': setUID = TRUE; break; case 't': sticky = TRUE; break; case 'l': locking = TRUE; break; default: goto invalidMode; } scanPtr++; } /* * Build mode map of specified values. */ newMode = 0; ugoMask = 0; if (user) { newMode |= rwxMask << 6; ugoMask |= 0700; } if (group) { newMode |= rwxMask << 3; ugoMask |= 0070; } if (other) { newMode |= rwxMask; ugoMask |= 0007; } if (setUID && user) newMode |= 04000; if ((setUID || locking) && group) newMode |= 02000; if (sticky) newMode |= 01000; /* * Add to cumulative mode based on operator. */ if (operator == '+') modeVal |= newMode; else if (operator == '-') modeVal &= ~newMode; else if (operator == '=') modeVal |= (modeVal & ugoMask) | newMode; if (*scanPtr == ',') scanPtr++; } return modeVal; invalidMode: TclX_AppendObjResult (interp, "invalid file mode \"", symMode, "\"", (char *) NULL); return -1; } /*----------------------------------------------------------------------------- * ChmodFileNameObj -- * Change the mode of a file by name. * * Parameters: * o interp - Pointer to the current interpreter, error messages will be * returned in the result. * o modeInfo - Infomation with the mode to set the file to. * o fileName - Name of the file to change. * Returns: * TCL_OK or TCL_ERROR. *----------------------------------------------------------------------------- */ static int ChmodFileNameObj (interp, modeInfo, fileNameObj) Tcl_Interp *interp; modeInfo_t modeInfo; Tcl_Obj *fileNameObj; { char *filePath; struct stat fileStat; Tcl_DString pathBuf; int newMode; char *fileName; Tcl_DStringInit (&pathBuf); fileName = Tcl_GetStringFromObj (fileNameObj, NULL); filePath = Tcl_TranslateFileName (interp, fileName, &pathBuf); if (filePath == NULL) { Tcl_DStringFree (&pathBuf); return TCL_ERROR; } if (modeInfo.symMode != NULL) { if (stat (filePath, &fileStat) != 0) goto fileError; newMode = ConvSymMode (interp, modeInfo.symMode, fileStat.st_mode & 07777); if (newMode < 0) goto errorExit; } else { newMode = modeInfo.absMode; } if (TclXOSchmod (interp, filePath, (unsigned short) newMode) < 0) return TCL_ERROR; Tcl_DStringFree (&pathBuf); return TCL_OK; fileError: TclX_AppendObjResult (interp, filePath, ": ", Tcl_PosixError (interp), (char *) NULL); errorExit: Tcl_DStringFree (&pathBuf); return TCL_ERROR; } /*----------------------------------------------------------------------------- * ChmodFileIdObj -- * Change the mode of a file by file id. * * Parameters: * o interp - Pointer to the current interpreter, error messages will be * returned in the result. * o modeInfo - Infomation with the mode to set the file to. * o fileId - The Tcl file id. * Returns: * TCL_OK or TCL_ERROR. *----------------------------------------------------------------------------- */ static int ChmodFileIdObj (interp, modeInfo, fileIdObj) Tcl_Interp *interp; modeInfo_t modeInfo; Tcl_Obj *fileIdObj; { Tcl_Channel channel; struct stat fileStat; int newMode; channel = TclX_GetOpenChannelObj (interp, fileIdObj, 0); if (channel == NULL) { return TCL_ERROR; } if (modeInfo.symMode != NULL) { if (TclXOSFstat (interp, channel, &fileStat, NULL) != 0) return TCL_ERROR; newMode = ConvSymMode (interp, modeInfo.symMode, fileStat.st_mode & 07777); if (newMode < 0) return TCL_ERROR; } else { newMode = modeInfo.absMode; } if (TclXOSfchmod (interp, channel, (unsigned short) newMode, FILE_ID_OPT) == TCL_ERROR) return TCL_ERROR; return TCL_OK; } /*----------------------------------------------------------------------------- * Tcl_ChmodObjCmd -- * Implements the TCL chmod command: * chmod [fileid] mode filelist * * Results: * Standard TCL results, may return the UNIX system error message. * *----------------------------------------------------------------------------- */ static int TclX_ChmodObjCmd (clientData, interp, objc, objv) ClientData clientData; Tcl_Interp *interp; int objc; Tcl_Obj *CONST objv[]; { int objIdx, idx, fileObjc, fileIds, result; modeInfo_t modeInfo; Tcl_Obj **fileObjv; char *fileIdsString; char *modeString; int modeBits; /* * Options are not parsable just looking for "-", since modes can * start with "-". */ fileIds = FALSE; objIdx = 1; if (objc > 1) { fileIdsString = Tcl_GetStringFromObj (objv [objIdx], NULL); if (STREQU (fileIdsString, FILE_ID_OPT)) { fileIds = TRUE; objIdx++; } } if (objIdx != objc - 2) return TclX_WrongArgs (interp, objv [0], "[-fileid] mode filelist"); modeString = Tcl_GetStringFromObj (objv [objIdx], NULL); if (ISDIGIT (modeString[0])) { if (Tcl_GetIntFromObj (interp, objv [objIdx], &modeBits) != TCL_OK) return TCL_ERROR; modeInfo.absMode = modeBits; modeInfo.symMode = NULL; } else { modeInfo.symMode = modeString; } if (Tcl_ListObjGetElements (interp, objv [objIdx + 1], &fileObjc, &fileObjv) != TCL_OK) return TCL_ERROR; result = TCL_OK; for (idx = 0; (idx < fileObjc) && (result == TCL_OK); idx++) { if (fileIds) { result = ChmodFileIdObj (interp, modeInfo, fileObjv [idx]); } else { result = ChmodFileNameObj (interp, modeInfo, fileObjv [idx]); } } return result; } /*----------------------------------------------------------------------------- * Tcl_ChownObjCmd -- * Implements the TCL chown command: * chown [-fileid] userGrpSpec filelist * * The valid formats of userGrpSpec are: * {owner}. {owner group} or {owner {}} * Results: * Standard TCL results, may return the UNIX system error message. *----------------------------------------------------------------------------- */ static int TclX_ChownObjCmd (clientData, interp, objc, objv) ClientData clientData; Tcl_Interp *interp; int objc; Tcl_Obj *CONST *objv; { int objIdx, ownerObjc, fileIds; Tcl_Obj **ownerObjv = NULL; unsigned options; char *fileIdsSwitch; char *owner, *group; int groupStrLen; /* * Parse options. */ fileIds = FALSE; for (objIdx = 1; objIdx < objc ; objIdx++) { fileIdsSwitch = Tcl_GetStringFromObj (objv[objIdx], NULL); if (fileIdsSwitch[0] != '-') break; if (STREQU (fileIdsSwitch, FILE_ID_OPT)) { fileIds = TRUE; } else { TclX_AppendObjResult (interp, "Invalid option \"", fileIdsSwitch, "\", expected \"", FILE_ID_OPT, "\"", (char *) NULL); return TCL_ERROR; } } if (objIdx != objc - 2) return TclX_WrongArgs (interp, objv[0], "[-fileid] user|{user group} filelist"); /* * Parse the owner/group parameter. */ if (Tcl_ListObjGetElements (interp, objv [objIdx], &ownerObjc, &ownerObjv) != TCL_OK) return TCL_ERROR; if ((ownerObjc < 1) || (ownerObjc > 2)) { TclX_AppendObjResult (interp, "owner arg should be: user or {user group}", (char *) NULL); goto errorExit; } options = TCLX_CHOWN; owner = Tcl_GetStringFromObj (ownerObjv [0], NULL); group = NULL; if (ownerObjc == 2) { options |= TCLX_CHGRP; group = Tcl_GetStringFromObj (ownerObjv [1], &groupStrLen); if (groupStrLen == 0) group = NULL; } /* * Finally, change ownership. */ if (fileIds) { if (TclXOSFChangeOwnGrpObj (interp, options, owner, group, objv [objIdx + 1], "chown -fileid") != TCL_OK) goto errorExit; } else { if (TclXOSChangeOwnGrpObj (interp, options, owner, group, objv [objIdx + 1], "chown") != TCL_OK) goto errorExit; } return TCL_OK; errorExit: return TCL_ERROR; } /*----------------------------------------------------------------------------- * Tcl_ChgrpObjCmd -- * Implements the TCL chgrp command: * chgrp [-fileid] group filelist * * Results: * Standard TCL results, may return the UNIX system error message. * *----------------------------------------------------------------------------- */ static int TclX_ChgrpObjCmd (clientData, interp, objc, objv) ClientData clientData; Tcl_Interp *interp; int objc; Tcl_Obj *CONST objv[]; { int objIdx, fileIds; char *fileIdsSwitch, *groupString; fileIds = FALSE; for (objIdx = 1; objIdx < objc; objIdx++) { fileIdsSwitch = Tcl_GetStringFromObj (objv [objIdx], NULL); if (fileIdsSwitch[0] != '-') break; if (STREQU (fileIdsSwitch, FILE_ID_OPT)) { fileIds = TRUE; } else { TclX_AppendObjResult (interp, "Invalid option \"", fileIdsSwitch, "\", expected \"", FILE_ID_OPT, "\"", (char *) NULL); return TCL_ERROR; } } if (objIdx != objc - 2) return TclX_WrongArgs (interp, objv [0], "[-fileid] group filelist"); groupString = Tcl_GetStringFromObj (objv [objIdx], NULL); if (fileIds) { if (TclXOSFChangeOwnGrpObj (interp, TCLX_CHGRP, NULL, groupString, objv [objIdx + 1], "chgrp - fileid") != TCL_OK) goto errorExit; } else { if (TclXOSChangeOwnGrpObj (interp, TCLX_CHGRP, NULL, groupString, objv [objIdx + 1], "chgrp") != TCL_OK) goto errorExit; } return TCL_OK; errorExit: return TCL_ERROR; } /*----------------------------------------------------------------------------- * TclX_ChmodInit -- * Initialize the chmod, chgrp and chown commands. *----------------------------------------------------------------------------- */ void TclX_ChmodInit (interp) Tcl_Interp *interp; { Tcl_CreateObjCommand (interp, "chgrp", TclX_ChgrpObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc*) NULL); Tcl_CreateObjCommand (interp, "chmod", TclX_ChmodObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc*) NULL); Tcl_CreateObjCommand (interp, "chown", TclX_ChownObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc*) NULL); } tclx8.4-8.4.1.orig/generic/tclXlib.c0000644000000000000000000007705312046313170013747 0ustar /* * tclXlib.c -- * * Tcl commands to load libraries of Tcl code. *----------------------------------------------------------------------------- * Copyright 1991-1999 Karl Lehenbauer and Mark Diekhans. * * Permission to use, copy, modify, and distribute this software and its * documentation for any purpose and without fee is hereby granted, provided * that the above copyright notice appear in all copies. Karl Lehenbauer and * Mark Diekhans make no representations about the suitability of this * software for any purpose. It is provided "as is" without express or * implied warranty. *----------------------------------------------------------------------------- * $Id: tclXlib.c,v 1.5 2008/12/15 20:00:27 andreas_kupries Exp $ *----------------------------------------------------------------------------- */ /*----------------------------------------------------------------------------- * The Extended Tcl library code is integrated with Tcl's by providing a * modified version of the Tcl auto_load proc that calls tclx_load_tndxs. * * The following data structures are kept as Tcl variables so they can be * accessed from Tcl: * * o auto_index - An array indexed by command name and contains code to * execute to make the command available. Normally contains either: * "source file" * "auto_pkg_load package" * o auto_pkg_index - Indexed by package name. *----------------------------------------------------------------------------- */ #include "tclExtdInt.h" /* * Names of Tcl variables that are used. */ static char *AUTO_INDEX = "auto_index"; static char *AUTO_PKG_INDEX = "auto_pkg_index"; /* * Command to pass to Tcl_GlobalEval to load the file autoload.tcl. * This is a global rather than a local so it will work with K&R compilers. * Its writable so it works with gcc. */ #ifdef HAVE_TCL_STANDALONE static char autoloadCmd [] = "if [catch {source -rsrc autoload}] {\n\ source [file join $tclx_library autoload.tcl]\n\ }"; #else static char autoloadCmd [] = "source [file join $tclx_library autoload.tcl]"; #endif /* * Indicates the type of library index. */ typedef enum { TCLLIB_TNDX, /* *.tndx */ TCLLIB_TND /* *.tnd (.tndx in 8.3 land) */ } indexNameClass_t; /* * Prototypes of internal functions. */ static int EvalFilePart _ANSI_ARGS_((Tcl_Interp *interp, char *fileName, off_t offset, off_t length)); static char * MakeAbsFile _ANSI_ARGS_((Tcl_Interp *interp, char *fileName, Tcl_DString *absNamePtr)); static int SetPackageIndexEntry _ANSI_ARGS_((Tcl_Interp *interp, CONST84 char *packageName, CONST84 char *fileName, off_t offset, unsigned length)); static int GetPackageIndexEntry _ANSI_ARGS_((Tcl_Interp *interp, char *packageName, char **fileNamePtr, off_t *offsetPtr, unsigned *lengthPtr)); static int SetProcIndexEntry _ANSI_ARGS_((Tcl_Interp *interp, CONST84 char *procName, CONST84 char *package)); static void AddLibIndexErrorInfo _ANSI_ARGS_((Tcl_Interp *interp, char *indexName)); static int ProcessIndexFile _ANSI_ARGS_((Tcl_Interp *interp, char *tlibFilePath, char *tndxFilePath)); static int BuildPackageIndex _ANSI_ARGS_((Tcl_Interp *interp, char *tlibFilePath)); static int LoadPackageIndex _ANSI_ARGS_((Tcl_Interp *interp, char *tlibFilePath, indexNameClass_t indexNameClass)); static int LoadDirIndexCallback _ANSI_ARGS_((Tcl_Interp *interp, char *dirPath, char *fileName, int caseSensitive, ClientData clientData)); static int LoadDirIndexes _ANSI_ARGS_((Tcl_Interp *interp, char *dirName)); static int TclX_load_tndxsObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int TclX_Auto_load_pkgObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int TclX_LoadlibindexObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); /*----------------------------------------------------------------------------- * EvalFilePart -- * * Read in a byte range of a file and evaulate it. * * Parameters: * o interp - A pointer to the interpreter, error returned in result. * o fileName - The file to evaulate. * o offset - Byte offset into the file of the area to evaluate * o length - Number of bytes to evaulate. *----------------------------------------------------------------------------- */ static int EvalFilePart (interp, fileName, offset, length) Tcl_Interp *interp; char *fileName; off_t offset; off_t length; { Interp *iPtr = (Interp *) interp; int result, major, minor; off_t fileSize; Tcl_DString pathBuf, cmdBuf; char *buf; Tcl_Channel channel = NULL; Tcl_ResetResult (interp); Tcl_DStringInit (&pathBuf); Tcl_DStringInit (&cmdBuf); fileName = Tcl_TranslateFileName (interp, fileName, &pathBuf); if (fileName == NULL) goto errorExit; channel = Tcl_OpenFileChannel (interp, fileName, "r", 0); if (channel == NULL) goto errorExit; if (TclXOSGetFileSize (channel, &fileSize) == TCL_ERROR) goto posixError; if ((fileSize < offset + length) || (offset < 0)) { TclX_AppendObjResult (interp, "range to eval outside of file bounds in \"", fileName, "\", index file probably corrupt", (char *) NULL); goto errorExit; } if (Tcl_Seek (channel, offset, SEEK_SET) < 0) goto posixError; Tcl_DStringSetLength (&cmdBuf, length + 1); if (Tcl_Read (channel, cmdBuf.string, length) != length) { if (Tcl_Eof (channel)) goto prematureEof; else goto posixError; } cmdBuf.string [length] = '\0'; if (Tcl_Close (NULL, channel) != 0) goto posixError; channel = NULL; /* * The internal scriptFile element changed from char* to Tcl_Obj* in 8.4. */ Tcl_GetVersion(&major, &minor, NULL, NULL); if ((major > 8) || (minor > 3)) { Tcl_Obj *oldScriptFile = (Tcl_Obj *) iPtr->scriptFile; Tcl_Obj *newobj = Tcl_NewStringObj(fileName, -1); Tcl_IncrRefCount(newobj); iPtr->scriptFile = (void *) newobj; result = Tcl_GlobalEval (interp, cmdBuf.string); iPtr->scriptFile = (void *) oldScriptFile; Tcl_DecrRefCount(newobj); } else { char *oldScriptFile = (char *) iPtr->scriptFile; iPtr->scriptFile = (void *) fileName; result = Tcl_GlobalEval (interp, cmdBuf.string); iPtr->scriptFile = (void *) oldScriptFile; } Tcl_DStringFree (&pathBuf); Tcl_DStringFree (&cmdBuf); if (result != TCL_ERROR) { return TCL_OK; } /* * An error occured in the command, record information telling where it * came from. */ buf = ckalloc (strlen (fileName) + 64); sprintf (buf, "\n (file \"%s\" line %d)", fileName, ERRORLINE(interp)); Tcl_AddErrorInfo (interp, buf); ckfree (buf); goto errorExit; /* * Errors accessing the file once its opened are handled here. */ posixError: TclX_AppendObjResult (interp, "error accessing: ", fileName, ": ", Tcl_PosixError (interp), (char *) NULL); goto errorExit; prematureEof: TclX_AppendObjResult (interp, "premature EOF on: ", fileName, (char *) NULL); goto errorExit; errorExit: if (channel != NULL) Tcl_Close (NULL, channel); Tcl_DStringFree (&pathBuf); Tcl_DStringFree (&cmdBuf); return TCL_ERROR; } /*----------------------------------------------------------------------------- * MakeAbsFile -- * * Convert a file name to an absolute path. This handles file name translation * and preappend the current directory name if the path is relative. * * Parameters * o interp - A pointer to the interpreter, error returned in result. * o fileName - File name (should not start with a "/"). * o absNamePtr - The name is returned in this dynamic string. It * should be initialized. * Returns: * A pointer to the file name in the dynamic string or NULL if an error * occured. *----------------------------------------------------------------------------- */ static char * MakeAbsFile (interp, fileName, absNamePtr) Tcl_Interp *interp; char *fileName; Tcl_DString *absNamePtr; { char *curDir; Tcl_DString joinBuf, cwdBuffer; Tcl_DStringSetLength (absNamePtr, 1); Tcl_DStringInit (&cwdBuffer); fileName = Tcl_TranslateFileName (interp, fileName, absNamePtr); if (fileName == NULL) goto errorExit; /* * If its already absolute. If name translation didn't actually * copy the name to the buffer, we must do it now. */ if (Tcl_GetPathType (fileName) == TCL_PATH_ABSOLUTE) { if (fileName != absNamePtr->string) { Tcl_DStringAppend (absNamePtr, fileName, -1); } return Tcl_DStringValue (absNamePtr); } /* * Otherwise its relative to the current directory, get the directory * and join into a path. */ curDir = Tcl_GetCwd (interp, &cwdBuffer); if (curDir == NULL) goto errorExit; Tcl_DStringInit (&joinBuf); TclX_JoinPath (curDir, fileName, &joinBuf); Tcl_DStringSetLength (absNamePtr, 0); Tcl_DStringAppend (absNamePtr, joinBuf.string, -1); Tcl_DStringFree (&joinBuf); Tcl_DStringFree (&cwdBuffer); return Tcl_DStringValue (absNamePtr); errorExit: Tcl_DStringFree (&cwdBuffer); return NULL; } /*----------------------------------------------------------------------------- * SetPackageIndexEntry -- * * Set a package entry in the auto_pkg_index array in the form: * * auto_pkg_index($packageName) [list $filename $offset $length] * * Duplicate package entries are overwritten. * * Parameters * o interp - A pointer to the interpreter, error returned in result. * o packageName - Package name. * o fileName - Absolute file name of the file containing the package. * o offset - String containing the numeric start of the package. * o length - String containing the numeric length of the package. * Returns: * TCL_OK or TCL_ERROR. *----------------------------------------------------------------------------- */ static int SetPackageIndexEntry (interp, packageName, fileName, offset, length) Tcl_Interp *interp; CONST84 char *packageName; CONST84 char *fileName; off_t offset; unsigned length; { Tcl_Obj *pkgDataObjv [3], *pkgDataPtr; /* * Build up the list of values to save. */ pkgDataObjv [0] = Tcl_NewStringObj (fileName, -1); pkgDataObjv [1] = Tcl_NewIntObj ((int) offset); pkgDataObjv [2] = Tcl_NewIntObj ((int) length); pkgDataPtr = Tcl_NewListObj (3, pkgDataObjv); if (Tcl_SetVar2Ex(interp, AUTO_PKG_INDEX, packageName, pkgDataPtr, TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) { Tcl_DecrRefCount (pkgDataPtr); return TCL_ERROR; } return TCL_OK; } /*----------------------------------------------------------------------------- * GetPackageIndexEntry -- * * Get a package entry from the auto_pkg_index array. * * Parameters * o interp - A pointer to the interpreter, error returned in result. * o packageName - Package name to find. * o fileNamePtr - The file name for the library file is returned here. * This should be freed by the caller. * o offsetPtr - Start of the package in the library. * o lengthPtr - Length of the package in the library. * Returns: * TCL_OK or TCL_ERROR. *----------------------------------------------------------------------------- */ static int GetPackageIndexEntry (interp, packageName, fileNamePtr, offsetPtr, lengthPtr) Tcl_Interp *interp; char *packageName; char **fileNamePtr; off_t *offsetPtr; unsigned *lengthPtr; { int pkgDataObjc; Tcl_Obj **pkgDataObjv, *pkgDataPtr; /* * Look up the package entry in the array. */ pkgDataPtr = Tcl_GetVar2Ex(interp, AUTO_PKG_INDEX, packageName, TCL_GLOBAL_ONLY); if (pkgDataPtr == NULL) { TclX_AppendObjResult (interp, "entry not found in \"auto_pkg_index\"", " for package \"", packageName, "\"", (char *) NULL); goto errorExit; } /* * Extract the data from the array entry. */ if (Tcl_ListObjGetElements (interp, pkgDataPtr, &pkgDataObjc, &pkgDataObjv) != TCL_OK) goto invalidEntry; if (pkgDataObjc != 3) goto invalidEntry; if (TclX_GetOffsetFromObj (interp, pkgDataObjv [1], offsetPtr) != TCL_OK) goto invalidEntry; if (TclX_GetUnsignedFromObj (interp, pkgDataObjv [2], lengthPtr) != TCL_OK) goto invalidEntry; *fileNamePtr = Tcl_GetStringFromObj (pkgDataObjv [0], NULL); *fileNamePtr = ckstrdup (*fileNamePtr); return TCL_OK; /* * Exit point when an invalid entry is found. */ invalidEntry: Tcl_ResetResult (interp); TclX_AppendObjResult (interp, "invalid entry in \"auto_pkg_index\"", " for package \"", packageName, "\"", (char *) NULL); errorExit: return TCL_ERROR; } /*----------------------------------------------------------------------------- * SetProcIndexEntry -- * * Set the proc entry in the auto_index array. These entry contains a command * to make the proc available from a package. * * Parameters * o interp - A pointer to the interpreter, error returned in result. * o procName - The Tcl proc name. * o package - Pacakge containing the proc. * Returns: * TCL_OK or TCL_ERROR. *----------------------------------------------------------------------------- */ static int SetProcIndexEntry (interp, procName, package) Tcl_Interp *interp; CONST84 char *procName; CONST84 char *package; { Tcl_DString command; CONST84 char *result; Tcl_DStringInit (&command); Tcl_DStringAppendElement (&command, "auto_load_pkg"); Tcl_DStringAppendElement (&command, package); result = Tcl_SetVar2 (interp, AUTO_INDEX, procName, command.string, TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG); Tcl_DStringFree (&command); return (result == NULL) ? TCL_ERROR : TCL_OK; } /*----------------------------------------------------------------------------- * AddLibIndexErrorInfo -- * * Add information to the error info stack about index that just failed. * This is generic for both tclIndex and .tlib indexs * * Parameters * o interp - A pointer to the interpreter, error returned in result. * o indexName - The name of the index. *----------------------------------------------------------------------------- */ static void AddLibIndexErrorInfo (interp, indexName) Tcl_Interp *interp; char *indexName; { char *msg; msg = ckalloc (strlen (indexName) + 60); strcpy (msg, "\n while loading Tcl library index \""); strcat (msg, indexName); strcat (msg, "\""); Tcl_AddObjErrorInfo (interp, msg, -1); ckfree (msg); } /*----------------------------------------------------------------------------- * ProcessIndexFile -- * * Open and process a package library index file (.tndx). Creates entries * in the auto_index and auto_pkg_index arrays. Existing entries are over * written. * * Parameters * o interp - A pointer to the interpreter, error returned in result. * o tlibFilePath - Absolute path name to the library file. * o tndxFilePath - Absolute path name to the library file index. * Returns: * TCL_OK or TCL_ERROR. *----------------------------------------------------------------------------- */ static int ProcessIndexFile (interp, tlibFilePath, tndxFilePath) Tcl_Interp *interp; char *tlibFilePath; char *tndxFilePath; { Tcl_Channel indexChannel = NULL; Tcl_DString lineBuffer; int lineArgc, idx, result, tmpNum; CONST84 char **lineArgv = NULL; off_t offset; unsigned length; Tcl_DStringInit (&lineBuffer); indexChannel = Tcl_OpenFileChannel (interp, tndxFilePath, "r", 0); if (indexChannel == NULL) return TCL_ERROR; while (TRUE) { Tcl_DStringSetLength (&lineBuffer, 0); if (Tcl_Gets (indexChannel, &lineBuffer) < 0) { if (Tcl_Eof (indexChannel)) goto reachedEOF; else goto fileError; } if ((Tcl_SplitList (interp, lineBuffer.string, &lineArgc, &lineArgv) != TCL_OK) || (lineArgc < 4)) goto formatError; /* * lineArgv [0] is the package name. * lineArgv [1] is the package offset in the library. * lineArgv [2] is the package length in the library. * lineArgv [3-n] are the entry procedures for the package. */ if (Tcl_GetInt (interp, lineArgv [1], &tmpNum) != TCL_OK) goto errorExit; if (tmpNum < 0) goto formatError; offset = (off_t) tmpNum; if (Tcl_GetInt (interp, lineArgv [2], &tmpNum) != TCL_OK) goto errorExit; if (tmpNum < 0) goto formatError; length = (unsigned) tmpNum; result = SetPackageIndexEntry (interp, lineArgv [0], tlibFilePath, offset, length); if (result == TCL_ERROR) goto errorExit; /* * If the package is not duplicated, add the commands to load * the procedures. */ if (result != TCL_CONTINUE) { for (idx = 3; idx < lineArgc; idx++) { if (SetProcIndexEntry (interp, lineArgv [idx], lineArgv [0]) != TCL_OK) goto errorExit; } } ckfree ((char *) lineArgv); lineArgv = NULL; } reachedEOF: Tcl_DStringFree (&lineBuffer); if (Tcl_Close (NULL, indexChannel) != TCL_OK) goto fileError; return TCL_OK; /* * Handle format error in library input line. */ formatError: Tcl_ResetResult (interp); TclX_AppendObjResult (interp, "format error in library index \"", tndxFilePath, "\" (", lineBuffer.string, ")", (char *) NULL); goto errorExit; fileError: TclX_AppendObjResult (interp, "error accessing package index file \"", tndxFilePath, "\": ", Tcl_PosixError (interp), (char *) NULL); goto errorExit; /* * Error exit here, releasing resources and closing the file. */ errorExit: if (lineArgv != NULL) ckfree ((char *) lineArgv); Tcl_DStringFree (&lineBuffer); if (indexChannel != NULL) Tcl_Close (NULL, indexChannel); return TCL_ERROR; } /*----------------------------------------------------------------------------- * BuildPackageIndex -- * * Call the "buildpackageindex" Tcl procedure to rebuild a package index. * This is found in the directory pointed to by the $tclx_library variable. * * Parameters * o interp - A pointer to the interpreter, error returned in result. * o tlibFilePath - Absolute path name to the library file. * Returns: * TCL_OK or TCL_ERROR. *----------------------------------------------------------------------------- */ static int BuildPackageIndex (interp, tlibFilePath) Tcl_Interp *interp; char *tlibFilePath; { Tcl_DString command; int result; Tcl_DStringInit (&command); Tcl_DStringAppend (&command, "if [catch {source -rsrc buildidx}] {source [file join $tclx_library buildidx.tcl]};", -1); Tcl_DStringAppend (&command, "buildpackageindex ", -1); Tcl_DStringAppend (&command, tlibFilePath, -1); result = Tcl_GlobalEval (interp, command.string); Tcl_DStringFree (&command); if (result == TCL_ERROR) return TCL_ERROR; Tcl_ResetResult (interp); return result; } /*----------------------------------------------------------------------------- * LoadPackageIndex -- * * Load a package .tndx file. Rebuild .tndx if non-existant or out of * date. * * Parameters * o interp - A pointer to the interpreter, error returned in result. * o tlibFilePath - Absolute path name to the library file. * o indexNameClass - TCLLIB_TNDX if the index file should the suffix * ".tndx" or TCLLIB_TND if it should have ".tnd". * Returns: * TCL_OK or TCL_ERROR. *----------------------------------------------------------------------------- */ static int LoadPackageIndex (interp, tlibFilePath, indexNameClass) Tcl_Interp *interp; char *tlibFilePath; indexNameClass_t indexNameClass; { Tcl_DString tndxFilePath; struct stat tlibStat; struct stat tndxStat; Tcl_DStringInit (&tndxFilePath); /* * Modify library file path to be the index file path. */ Tcl_DStringAppend (&tndxFilePath, tlibFilePath, -1); tndxFilePath.string [tndxFilePath.length - 3] = 'n'; tndxFilePath.string [tndxFilePath.length - 2] = 'd'; if (indexNameClass == TCLLIB_TNDX) tndxFilePath.string [tndxFilePath.length - 1] = 'x'; /* * Get library's modification time. If the file can't be accessed, set * time so the library does not get built. Other code will report the * error. */ if (stat (tlibFilePath, &tlibStat) < 0) tlibStat.st_mtime = MAXINT; /* * Get the time for the index. If the file does not exists or is * out of date, rebuild it. */ if ((stat (tndxFilePath.string, &tndxStat) < 0) || (tndxStat.st_mtime < tlibStat.st_mtime)) { if (BuildPackageIndex (interp, tlibFilePath) != TCL_OK) goto errorExit; } if (ProcessIndexFile (interp, tlibFilePath, tndxFilePath.string) != TCL_OK) goto errorExit; Tcl_DStringFree (&tndxFilePath); return TCL_OK; errorExit: AddLibIndexErrorInfo (interp, tndxFilePath.string); Tcl_DStringFree (&tndxFilePath); return TCL_ERROR; } /*----------------------------------------------------------------------------- * LoadDirIndexCallback -- * * Function called for every directory entry for LoadDirIndexes. * * Parameters * o interp - Interp is passed though. * o dirPath - Normalized path to directory. * o fileName - Tcl normalized file name in directory. * o caseSensitive - Are the file names case sensitive? Always * TRUE on Unix. * o clientData - Pointer to a boolean that is set to TRUE if an error * occures while porocessing the index file. * Returns: * TCL_OK or TCL_ERROR. *----------------------------------------------------------------------------- */ static int LoadDirIndexCallback (interp, dirPath, fileName, caseSensitive, clientData) Tcl_Interp *interp; char *dirPath; char *fileName; int caseSensitive; ClientData clientData; { int *indexErrorPtr = (int *) clientData; int nameLen; char *chkName; indexNameClass_t indexNameClass; Tcl_DString chkNameBuf, filePath; /* * If the volume not case sensitive, convert the name to lower case. */ Tcl_DStringInit (&chkNameBuf); chkName = fileName; if (!caseSensitive) { chkName = Tcl_DStringAppend (&chkNameBuf, fileName, -1); TclX_DownShift (chkName, chkName); } /* * Figure out if its an index file. */ nameLen = strlen (chkName); if ((nameLen > 5) && STREQU (chkName + nameLen - 5, ".tlib")) { indexNameClass = TCLLIB_TNDX; } else if ((nameLen > 4) && STREQU (chkName + nameLen - 4, ".tli")) { indexNameClass = TCLLIB_TND; } else { Tcl_DStringFree (&chkNameBuf); return TCL_OK; /* Not an index, skip */ } Tcl_DStringFree (&chkNameBuf); /* * Assemble full path to library file. */ Tcl_DStringInit (&filePath); TclX_JoinPath (dirPath, fileName, &filePath); /* * Skip index it can't be accessed. */ if (access (filePath.string, R_OK) < 0) goto exitPoint; /* * Process the index according to its type. */ if (LoadPackageIndex (interp, filePath.string, indexNameClass) != TCL_OK) goto errorExit; exitPoint: Tcl_DStringFree (&filePath); return TCL_OK; errorExit: Tcl_DStringFree (&filePath); *indexErrorPtr = TRUE; return TCL_ERROR; } /*----------------------------------------------------------------------------- * LoadDirIndexes -- * * Load the indexes for all package library (.tlib) or a Ousterhout * "tclIndex" file in a directory. Nonexistent or unreadable directories * are skipped. * * Parameters * o interp - A pointer to the interpreter, error returned in result. * o dirName - The absolute path name of the directory to search for * libraries. *----------------------------------------------------------------------------- */ static int LoadDirIndexes (interp, dirName) Tcl_Interp *interp; char *dirName; { int indexError = FALSE; /* * This is a little tricky. We want to skip directories we can't read, * read, but if we get an error processing an index, we want * to report it. A boolean is passed in to indicate if the error * returned involved parsing the file. */ if (TclXOSWalkDir (interp, dirName, FALSE, /* hidden */ LoadDirIndexCallback, (ClientData) &indexError) == TCL_ERROR) { if (!indexError) { Tcl_ResetResult (interp); return TCL_OK; } return TCL_ERROR; } return TCL_OK; } /*----------------------------------------------------------------------------- * TclX_load_tndxsObjCmd -- * * Implements the command: * tclx_load_tndxs dir * * Which is called from auto_load to load a .tndx files in a directory. *----------------------------------------------------------------------------- */ static int TclX_load_tndxsObjCmd (clientData, interp, objc, objv) ClientData clientData; Tcl_Interp *interp; int objc; Tcl_Obj *CONST objv[]; { char *dirname; if (objc != 2) { return TclX_WrongArgs (interp, objv [0], "dir"); } dirname = Tcl_GetStringFromObj (objv[1], NULL); return LoadDirIndexes (interp, dirname); } /*----------------------------------------------------------------------------- * TclX_Auto_load_pkgObjCmd -- * * Implements the command: * auto_load_pkg package * * Which is called to load a .tlib package who's index has already been loaded. *----------------------------------------------------------------------------- */ static int TclX_Auto_load_pkgObjCmd (clientData, interp, objc, objv) ClientData clientData; Tcl_Interp *interp; int objc; Tcl_Obj *CONST objv[]; { char *fileName; off_t offset; unsigned length; int result; if (objc != 2) { return TclX_WrongArgs (interp, objv [0], "package"); } if (GetPackageIndexEntry (interp, Tcl_GetStringFromObj (objv [1], NULL), &fileName, &offset, &length) != TCL_OK) return TCL_ERROR; result = EvalFilePart (interp, fileName, offset, length); ckfree (fileName); return result; } /*----------------------------------------------------------------------------- * TclX_LoadlibindexObjCmd -- * * This procedure is invoked to process the "Loadlibindex" Tcl command: * * loadlibindex libfile * * which loads the index for a package library (.tlib) or a Ousterhout * "tclIndex" file. New package definitions will override existing ones. *----------------------------------------------------------------------------- */ static int TclX_LoadlibindexObjCmd (clientData, interp, objc, objv) ClientData clientData; Tcl_Interp *interp; int objc; Tcl_Obj *CONST objv[]; { char *pathName; Tcl_DString pathNameBuf; int pathLen; Tcl_DStringInit (&pathNameBuf); if (objc != 2) { return TclX_WrongArgs (interp, objv [0], "libFile"); } pathName = MakeAbsFile (interp, Tcl_GetStringFromObj (objv [1], NULL), &pathNameBuf); if (pathName == NULL) return TCL_ERROR; /* * Find the length of the directory name. Validate that we have a .tlib * extension or file name is "tclIndex" and call the routine to process * the specific type of index. */ pathLen = strlen (pathName); if ((pathLen > 5) && STREQU (pathName + pathLen - 5, ".tlib")) { if (LoadPackageIndex (interp, pathName, TCLLIB_TNDX) != TCL_OK) goto errorExit; } else if ((pathLen > 4) && STREQU (pathName + pathLen - 4, ".tli")) { if (LoadPackageIndex (interp, pathName, TCLLIB_TND) != TCL_OK) goto errorExit; } else { TclX_AppendObjResult (interp, "invalid library name, must have ", "an extension of \".tlib\", or \".tli\", got \"", Tcl_GetStringFromObj (objv [1], NULL), "\"", (char *) NULL); goto errorExit; } Tcl_DStringFree (&pathNameBuf); return TCL_OK; errorExit: Tcl_DStringFree (&pathNameBuf); return TCL_ERROR;; } /*----------------------------------------------------------------------------- * TclX_LibraryInit -- * * Initialize the Extended Tcl library facility commands. *----------------------------------------------------------------------------- */ int TclX_LibraryInit (interp) Tcl_Interp *interp; { int result; /* Hack in our own auto-loading */ result = Tcl_EvalEx(interp, autoloadCmd, -1, TCL_EVAL_GLOBAL); if (result == TCL_ERROR) { return TCL_ERROR; } Tcl_CreateObjCommand (interp, "tclx_load_tndxs", TclX_load_tndxsObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc*) NULL); Tcl_CreateObjCommand (interp, "auto_load_pkg", TclX_Auto_load_pkgObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc*) NULL); Tcl_CreateObjCommand (interp, "loadlibindex", TclX_LoadlibindexObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc*) NULL); Tcl_ResetResult (interp); return TCL_OK; } tclx8.4-8.4.1.orig/generic/tclXfilecmds.c0000644000000000000000000002451412046313167014767 0ustar /* * tclXfilecmds.c * * Extended Tcl file-related commands. *----------------------------------------------------------------------------- * Copyright 1991-1999 Karl Lehenbauer and Mark Diekhans. * * Permission to use, copy, modify, and distribute this software and its * documentation for any purpose and without fee is hereby granted, provided * that the above copyright notice appear in all copies. Karl Lehenbauer and * Mark Diekhans make no representations about the suitability of this * software for any purpose. It is provided "as is" without express or * implied warranty. *----------------------------------------------------------------------------- * $Id: tclXfilecmds.c,v 1.2 2002/09/26 00:19:18 hobbs Exp $ *----------------------------------------------------------------------------- */ #include "tclExtdInt.h" static char *FILE_ID_OPT = "-fileid"; /* * Prototypes of internal functions. */ static int TruncateByPath _ANSI_ARGS_((Tcl_Interp *interp, char *filePath, off_t newSize)); static int ReadDirCallback _ANSI_ARGS_((Tcl_Interp *interp, char *path, char *fileName, int caseSensitive, ClientData clientData)); static int TclX_PipeObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int TclX_FtruncateObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int TclX_ReaddirObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); /*----------------------------------------------------------------------------- * Tcl_PipeObjCmd -- * Implements the pipe TCL command: * pipe ?fileId_var_r fileId_var_w? * * Results: * Standard TCL result. *----------------------------------------------------------------------------- */ static int TclX_PipeObjCmd (clientData, interp, objc, objv) ClientData clientData; Tcl_Interp *interp; int objc; Tcl_Obj *CONST objv[]; { Tcl_Channel channels [2]; CONST84 char *channelNames [2]; if (!((objc == 1) || (objc == 3))) return TclX_WrongArgs (interp, objv [0], "?fileId_var_r fileId_var_w?"); if (TclXOSpipe (interp, channels) != TCL_OK) return TCL_ERROR; channelNames [0] = Tcl_GetChannelName (channels [0]); channelNames [1] = Tcl_GetChannelName (channels [1]); if (objc == 1) { TclX_AppendObjResult (interp, channelNames [0], " ", channelNames [1], (char *) NULL); } else { if (Tcl_ObjSetVar2(interp, objv[1], NULL, Tcl_NewStringObj(channelNames [0], -1), TCL_PARSE_PART1|TCL_LEAVE_ERR_MSG) == NULL) goto errorExit; if (Tcl_ObjSetVar2(interp, objv[2], NULL, Tcl_NewStringObj(channelNames [1], -1), TCL_PARSE_PART1|TCL_LEAVE_ERR_MSG) == NULL) goto errorExit; } return TCL_OK; errorExit: Tcl_Close (NULL, channels [0]); Tcl_Close (NULL, channels [1]); return TCL_ERROR; } /*----------------------------------------------------------------------------- * TruncateByPath -- * * Truncate a file via path, if this is available on this system. * * Parameters: * o interp (I) - Error messages are returned in the interpreter. * o filePath (I) - Path to file. * o newSize (I) - Size to truncate the file to. * Returns: * TCL_OK or TCL_ERROR. *----------------------------------------------------------------------------- */ static int TruncateByPath (interp, filePath, newSize) Tcl_Interp *interp; char *filePath; off_t newSize; { #ifndef NO_TRUNCATE Tcl_DString pathBuf; Tcl_DStringInit (&pathBuf); filePath = Tcl_TranslateFileName (interp, filePath, &pathBuf); if (filePath == NULL) { Tcl_DStringFree (&pathBuf); return TCL_ERROR; } if (truncate (filePath, newSize) != 0) { TclX_AppendObjResult (interp, filePath, ": ", Tcl_PosixError (interp), (char *) NULL); Tcl_DStringFree (&pathBuf); return TCL_ERROR; } Tcl_DStringFree (&pathBuf); return TCL_OK; #else TclX_AppendObjResult (interp, "truncating files by path is not available ", "on this system", (char *) NULL); return TCL_ERROR; #endif } /*----------------------------------------------------------------------------- * Tcl_FtruncateObjCmd -- * Implements the Tcl ftruncate command: * ftruncate [-fileid] file newsize * * Results: * Standard TCL results, may return the UNIX system error message. * *----------------------------------------------------------------------------- */ static int TclX_FtruncateObjCmd (clientData, interp, objc, objv) ClientData clientData; Tcl_Interp *interp; int objc; Tcl_Obj *CONST objv[]; { int objIdx, fileIds; off_t newSize; long convSize; Tcl_Channel channel; char *switchString; char *pathString; fileIds = FALSE; for (objIdx = 1; objIdx < objc ; objIdx++) { switchString = Tcl_GetStringFromObj (objv [objIdx], NULL); if (*switchString != '-') break; if (STREQU (switchString, FILE_ID_OPT)) { fileIds = TRUE; } else { TclX_AppendObjResult (interp, "Invalid option \"", switchString, "\", expected \"", FILE_ID_OPT, "\"", (char *) NULL); return TCL_ERROR; } } if (objIdx != objc - 2) return TclX_WrongArgs (interp, objv [0], "[-fileid] file newsize"); if (Tcl_GetLongFromObj (interp, objv [objIdx + 1], &convSize) != TCL_OK) return TCL_ERROR; newSize = convSize; if (fileIds) { channel = TclX_GetOpenChannelObj (interp, objv [objIdx], 0); if (channel == NULL) return TCL_ERROR; return TclXOSftruncate (interp, channel, newSize, "-fileid option"); } else { pathString = Tcl_GetStringFromObj (objv [objIdx], NULL); return TruncateByPath (interp, pathString, newSize); } } /*----------------------------------------------------------------------------- * ReadDirCallback -- * * Callback procedure for walking directories. * Parameters: * o interp (I) - Interp is passed though. * o path (I) - Normalized path to directory. * o fileName (I) - Tcl normalized file name in directory. * o caseSensitive (I) - Are the file names case sensitive? Always * TRUE on Unix. * o clientData (I) - Tcl_DString to append names to. * Returns: * TCL_OK. *----------------------------------------------------------------------------- */ static int ReadDirCallback (interp, path, fileName, caseSensitive, clientData) Tcl_Interp *interp; char *path; char *fileName; int caseSensitive; ClientData clientData; { Tcl_Obj *fileListObj = (Tcl_Obj *) clientData; Tcl_Obj *fileNameObj; int result; fileNameObj = Tcl_NewStringObj (fileName, -1); result = Tcl_ListObjAppendElement (interp, fileListObj, fileNameObj); return result; } /*----------------------------------------------------------------------------- * Tcl_ReaddirObjCmd -- * Implements the rename TCL command: * readdir ?-hidden? dirPath * * Results: * Standard TCL result. *----------------------------------------------------------------------------- */ static int TclX_ReaddirObjCmd (clientData, interp, objc, objv) ClientData clientData; Tcl_Interp *interp; int objc; Tcl_Obj *CONST objv[]; { Tcl_DString pathBuf; char *dirPath; int hidden, status; Tcl_Obj *fileListObj; char *switchString; int dirPathLen; if ((objc < 2) || (objc > 3)) return TclX_WrongArgs (interp, objv [0], "?-hidden? dirPath"); if (objc == 2) { dirPath = Tcl_GetStringFromObj (objv [1], &dirPathLen); hidden = FALSE; } else { switchString = Tcl_GetStringFromObj (objv [1], NULL); if (!STREQU (switchString, "-hidden")) { TclX_AppendObjResult (interp, "expected option of \"-hidden\", got \"", switchString, "\"", (char *) NULL); return TCL_ERROR; } dirPath = Tcl_GetStringFromObj (objv [2], NULL); hidden = TRUE; } Tcl_DStringInit (&pathBuf); fileListObj = Tcl_NewObj (); dirPath = Tcl_TranslateFileName (interp, dirPath, &pathBuf); if (dirPath == NULL) { goto errorExit; } status = TclXOSWalkDir (interp, dirPath, hidden, ReadDirCallback, (ClientData) fileListObj); if (status == TCL_ERROR) goto errorExit; Tcl_DStringFree (&pathBuf); Tcl_SetObjResult (interp, fileListObj); return TCL_OK; errorExit: Tcl_DStringFree (&pathBuf); Tcl_DecrRefCount (fileListObj); return TCL_ERROR; } /*----------------------------------------------------------------------------- * TclX_FilecmdsInit -- * Initialize the file commands. *----------------------------------------------------------------------------- */ void TclX_FilecmdsInit (interp) Tcl_Interp *interp; { Tcl_CreateObjCommand (interp, "pipe", TclX_PipeObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc*) NULL); Tcl_CreateObjCommand (interp, "ftruncate", TclX_FtruncateObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc*) NULL); Tcl_CreateObjCommand (interp, "readdir", TclX_ReaddirObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc*) NULL); } tclx8.4-8.4.1.orig/configure0000755000000000000000000147006712046316771012512 0ustar #! /bin/sh # Guess values for system-dependent variables and create Makefiles. # Generated by GNU Autoconf 2.59 for tclx 8.4. # # Copyright (C) 2003 Free Software Foundation, Inc. # This configure script is free software; the Free Software Foundation # gives unlimited permission to copy, distribute and modify it. ## --------------------- ## ## M4sh Initialization. ## ## --------------------- ## # Be Bourne compatible if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then emulate sh NULLCMD=: # Zsh 3.x and 4.x performs word splitting on ${1+"$@"}, which # is contrary to our usage. Disable this feature. alias -g '${1+"$@"}'='"$@"' elif test -n "${BASH_VERSION+set}" && (set -o posix) >/dev/null 2>&1; then set -o posix fi DUALCASE=1; export DUALCASE # for MKS sh # Support unset when possible. if ( (MAIL=60; unset MAIL) || exit) >/dev/null 2>&1; then as_unset=unset else as_unset=false fi # Work around bugs in pre-3.0 UWIN ksh. $as_unset ENV MAIL MAILPATH PS1='$ ' PS2='> ' PS4='+ ' # NLS nuisances. for as_var in \ LANG LANGUAGE LC_ADDRESS LC_ALL LC_COLLATE LC_CTYPE LC_IDENTIFICATION \ LC_MEASUREMENT LC_MESSAGES LC_MONETARY LC_NAME LC_NUMERIC LC_PAPER \ LC_TELEPHONE LC_TIME do if (set +x; test -z "`(eval $as_var=C; export $as_var) 2>&1`"); then eval $as_var=C; export $as_var else $as_unset $as_var fi done # Required to use basename. if expr a : '\(a\)' >/dev/null 2>&1; then as_expr=expr else as_expr=false fi if (basename /) >/dev/null 2>&1 && test "X`basename / 2>&1`" = "X/"; then as_basename=basename else as_basename=false fi # Name of the executable. as_me=`$as_basename "$0" || $as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ X"$0" : 'X\(//\)$' \| \ X"$0" : 'X\(/\)$' \| \ . : '\(.\)' 2>/dev/null || echo X/"$0" | sed '/^.*\/\([^/][^/]*\)\/*$/{ s//\1/; q; } /^X\/\(\/\/\)$/{ s//\1/; q; } /^X\/\(\/\).*/{ s//\1/; q; } s/.*/./; q'` # PATH needs CR, and LINENO needs CR and PATH. # Avoid depending upon Character Ranges. as_cr_letters='abcdefghijklmnopqrstuvwxyz' as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ' as_cr_Letters=$as_cr_letters$as_cr_LETTERS as_cr_digits='0123456789' as_cr_alnum=$as_cr_Letters$as_cr_digits # The user is always right. if test "${PATH_SEPARATOR+set}" != set; then echo "#! /bin/sh" >conf$$.sh echo "exit 0" >>conf$$.sh chmod +x conf$$.sh if (PATH="/nonexistent;."; conf$$.sh) >/dev/null 2>&1; then PATH_SEPARATOR=';' else PATH_SEPARATOR=: fi rm -f conf$$.sh fi as_lineno_1=$LINENO as_lineno_2=$LINENO as_lineno_3=`(expr $as_lineno_1 + 1) 2>/dev/null` test "x$as_lineno_1" != "x$as_lineno_2" && test "x$as_lineno_3" = "x$as_lineno_2" || { # Find who we are. Look in the path if we contain no path at all # relative or not. case $0 in *[\\/]* ) as_myself=$0 ;; *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break done ;; esac # We did not find ourselves, most probably we were run as `sh COMMAND' # in which case we are not to be found in the path. if test "x$as_myself" = x; then as_myself=$0 fi if test ! -f "$as_myself"; then { echo "$as_me: error: cannot find myself; rerun with an absolute path" >&2 { (exit 1); exit 1; }; } fi case $CONFIG_SHELL in '') as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in /bin$PATH_SEPARATOR/usr/bin$PATH_SEPARATOR$PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for as_base in sh bash ksh sh5; do case $as_dir in /*) if ("$as_dir/$as_base" -c ' as_lineno_1=$LINENO as_lineno_2=$LINENO as_lineno_3=`(expr $as_lineno_1 + 1) 2>/dev/null` test "x$as_lineno_1" != "x$as_lineno_2" && test "x$as_lineno_3" = "x$as_lineno_2" ') 2>/dev/null; then $as_unset BASH_ENV || test "${BASH_ENV+set}" != set || { BASH_ENV=; export BASH_ENV; } $as_unset ENV || test "${ENV+set}" != set || { ENV=; export ENV; } CONFIG_SHELL=$as_dir/$as_base export CONFIG_SHELL exec "$CONFIG_SHELL" "$0" ${1+"$@"} fi;; esac done done ;; esac # Create $as_me.lineno as a copy of $as_myself, but with $LINENO # uniformly replaced by the line number. The first 'sed' inserts a # line-number line before each line; the second 'sed' does the real # work. The second script uses 'N' to pair each line-number line # with the numbered line, and appends trailing '-' during # substitution so that $LINENO is not a special case at line end. # (Raja R Harinath suggested sed '=', and Paul Eggert wrote the # second 'sed' script. Blame Lee E. McMahon for sed's syntax. :-) sed '=' <$as_myself | sed ' N s,$,-, : loop s,^\(['$as_cr_digits']*\)\(.*\)[$]LINENO\([^'$as_cr_alnum'_]\),\1\2\1\3, t loop s,-$,, s,^['$as_cr_digits']*\n,, ' >$as_me.lineno && chmod +x $as_me.lineno || { echo "$as_me: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&2 { (exit 1); exit 1; }; } # Don't try to exec as it changes $[0], causing all sort of problems # (the dirname of $[0] is not the place where we might find the # original and so on. Autoconf is especially sensible to this). . ./$as_me.lineno # Exit status is that of the last command. exit } case `echo "testing\c"; echo 1,2,3`,`echo -n testing; echo 1,2,3` in *c*,-n*) ECHO_N= ECHO_C=' ' ECHO_T=' ' ;; *c*,* ) ECHO_N=-n ECHO_C= ECHO_T= ;; *) ECHO_N= ECHO_C='\c' ECHO_T= ;; esac if expr a : '\(a\)' >/dev/null 2>&1; then as_expr=expr else as_expr=false fi rm -f conf$$ conf$$.exe conf$$.file echo >conf$$.file if ln -s conf$$.file conf$$ 2>/dev/null; then # We could just check for DJGPP; but this test a) works b) is more generic # and c) will remain valid once DJGPP supports symlinks (DJGPP 2.04). if test -f conf$$.exe; then # Don't use ln at all; we don't have any links as_ln_s='cp -p' else as_ln_s='ln -s' fi elif ln conf$$.file conf$$ 2>/dev/null; then as_ln_s=ln else as_ln_s='cp -p' fi rm -f conf$$ conf$$.exe conf$$.file if mkdir -p . 2>/dev/null; then as_mkdir_p=: else test -d ./-p && rmdir ./-p as_mkdir_p=false fi as_executable_p="test -f" # Sed expression to map a string onto a valid CPP name. as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" # Sed expression to map a string onto a valid variable name. as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" # IFS # We need space, tab and new line, in precisely that order. as_nl=' ' IFS=" $as_nl" # CDPATH. $as_unset CDPATH # Name of the host. # hostname on some systems (SVR3.2, Linux) returns a bogus exit status, # so uname gets run too. ac_hostname=`(hostname || uname -n) 2>/dev/null | sed 1q` exec 6>&1 # # Initializations. # ac_default_prefix=/usr/local ac_config_libobj_dir=. cross_compiling=no subdirs= MFLAGS= MAKEFLAGS= SHELL=${CONFIG_SHELL-/bin/sh} # Maximum number of lines to put in a shell here document. # This variable seems obsolete. It should probably be removed, and # only ac_max_sed_lines should be used. : ${ac_max_here_lines=38} # Identity of this package. PACKAGE_NAME='tclx' PACKAGE_TARNAME='tclx' PACKAGE_VERSION='8.4' PACKAGE_STRING='tclx 8.4' PACKAGE_BUGREPORT='' # Factoring default headers for most tests. ac_includes_default="\ #include #if HAVE_SYS_TYPES_H # include #endif #if HAVE_SYS_STAT_H # include #endif #if STDC_HEADERS # include # include #else # if HAVE_STDLIB_H # include # endif #endif #if HAVE_STRING_H # if !STDC_HEADERS && HAVE_MEMORY_H # include # endif # include #endif #if HAVE_STRINGS_H # include #endif #if HAVE_INTTYPES_H # include #else # if HAVE_STDINT_H # include # endif #endif #if HAVE_UNISTD_H # include #endif" ac_subst_vars='SHELL PATH_SEPARATOR PACKAGE_NAME PACKAGE_TARNAME PACKAGE_VERSION PACKAGE_STRING PACKAGE_BUGREPORT exec_prefix prefix program_transform_name bindir sbindir libexecdir datadir sysconfdir sharedstatedir localstatedir libdir includedir oldincludedir infodir mandir build_alias host_alias target_alias DEFS ECHO_C ECHO_N ECHO_T LIBS CYGPATH EXEEXT PKG_LIB_FILE PKG_STUB_LIB_FILE PKG_STUB_SOURCES PKG_STUB_OBJECTS PKG_TCL_SOURCES PKG_HEADERS PKG_INCLUDES PKG_LIBS PKG_CFLAGS TCL_VERSION TCL_BIN_DIR TCL_SRC_DIR TCL_LIB_FILE TCL_LIB_FLAG TCL_LIB_SPEC TCL_STUB_LIB_FILE TCL_STUB_LIB_FLAG TCL_STUB_LIB_SPEC TCL_LIBS TCL_DEFS TCL_EXTRA_CFLAGS TCL_LD_FLAGS TCL_SHLIB_LD_LIBS CC CFLAGS LDFLAGS CPPFLAGS ac_ct_CC OBJEXT CPP INSTALL_PROGRAM INSTALL_SCRIPT INSTALL_DATA SET_MAKE RANLIB ac_ct_RANLIB EGREP MATH_LIBS PKG_SOURCES PKG_OBJECTS TCL_TOP_DIR_NATIVE TCL_GENERIC_DIR_NATIVE TCL_UNIX_DIR_NATIVE TCL_WIN_DIR_NATIVE TCL_BMAP_DIR_NATIVE TCL_TOOL_DIR_NATIVE TCL_PLATFORM_DIR_NATIVE TCL_INCLUDES CLEANFILES TCL_THREADS SHARED_BUILD AR CELIB_DIR LIBOBJS DL_LIBS CFLAGS_DEBUG CFLAGS_OPTIMIZE CFLAGS_WARNING STLIB_LD SHLIB_LD SHLIB_LD_LIBS SHLIB_CFLAGS LD_LIBRARY_PATH_VAR TCL_DBGX CFLAGS_DEFAULT LDFLAGS_DEFAULT NROFF COL BUILDHELP HELP_DIR MAKE_LIB MAKE_SHARED_LIB MAKE_STATIC_LIB MAKE_STUB_LIB RANLIB_STUB TCLSH_PROG' ac_subst_files='' # Initialize some variables set by options. ac_init_help= ac_init_version=false # The variables have the same names as the options, with # dashes changed to underlines. cache_file=/dev/null exec_prefix=NONE no_create= no_recursion= prefix=NONE program_prefix=NONE program_suffix=NONE program_transform_name=s,x,x, silent= site= srcdir= verbose= x_includes=NONE x_libraries=NONE # Installation directory options. # These are left unexpanded so users can "make install exec_prefix=/foo" # and all the variables that are supposed to be based on exec_prefix # by default will actually change. # Use braces instead of parens because sh, perl, etc. also accept them. bindir='${exec_prefix}/bin' sbindir='${exec_prefix}/sbin' libexecdir='${exec_prefix}/libexec' datadir='${prefix}/share' sysconfdir='${prefix}/etc' sharedstatedir='${prefix}/com' localstatedir='${prefix}/var' libdir='${exec_prefix}/lib' includedir='${prefix}/include' oldincludedir='/usr/include' infodir='${prefix}/info' mandir='${prefix}/man' ac_prev= for ac_option do # If the previous option needs an argument, assign it. if test -n "$ac_prev"; then eval "$ac_prev=\$ac_option" ac_prev= continue fi ac_optarg=`expr "x$ac_option" : 'x[^=]*=\(.*\)'` # Accept the important Cygnus configure options, so we can diagnose typos. case $ac_option in -bindir | --bindir | --bindi | --bind | --bin | --bi) ac_prev=bindir ;; -bindir=* | --bindir=* | --bindi=* | --bind=* | --bin=* | --bi=*) bindir=$ac_optarg ;; -build | --build | --buil | --bui | --bu) ac_prev=build_alias ;; -build=* | --build=* | --buil=* | --bui=* | --bu=*) build_alias=$ac_optarg ;; -cache-file | --cache-file | --cache-fil | --cache-fi \ | --cache-f | --cache- | --cache | --cach | --cac | --ca | --c) ac_prev=cache_file ;; -cache-file=* | --cache-file=* | --cache-fil=* | --cache-fi=* \ | --cache-f=* | --cache-=* | --cache=* | --cach=* | --cac=* | --ca=* | --c=*) cache_file=$ac_optarg ;; --config-cache | -C) cache_file=config.cache ;; -datadir | --datadir | --datadi | --datad | --data | --dat | --da) ac_prev=datadir ;; -datadir=* | --datadir=* | --datadi=* | --datad=* | --data=* | --dat=* \ | --da=*) datadir=$ac_optarg ;; -disable-* | --disable-*) ac_feature=`expr "x$ac_option" : 'x-*disable-\(.*\)'` # Reject names that are not valid shell variable names. expr "x$ac_feature" : ".*[^-_$as_cr_alnum]" >/dev/null && { echo "$as_me: error: invalid feature name: $ac_feature" >&2 { (exit 1); exit 1; }; } ac_feature=`echo $ac_feature | sed 's/-/_/g'` eval "enable_$ac_feature=no" ;; -enable-* | --enable-*) ac_feature=`expr "x$ac_option" : 'x-*enable-\([^=]*\)'` # Reject names that are not valid shell variable names. expr "x$ac_feature" : ".*[^-_$as_cr_alnum]" >/dev/null && { echo "$as_me: error: invalid feature name: $ac_feature" >&2 { (exit 1); exit 1; }; } ac_feature=`echo $ac_feature | sed 's/-/_/g'` case $ac_option in *=*) ac_optarg=`echo "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"`;; *) ac_optarg=yes ;; esac eval "enable_$ac_feature='$ac_optarg'" ;; -exec-prefix | --exec_prefix | --exec-prefix | --exec-prefi \ | --exec-pref | --exec-pre | --exec-pr | --exec-p | --exec- \ | --exec | --exe | --ex) ac_prev=exec_prefix ;; -exec-prefix=* | --exec_prefix=* | --exec-prefix=* | --exec-prefi=* \ | --exec-pref=* | --exec-pre=* | --exec-pr=* | --exec-p=* | --exec-=* \ | --exec=* | --exe=* | --ex=*) exec_prefix=$ac_optarg ;; -gas | --gas | --ga | --g) # Obsolete; use --with-gas. with_gas=yes ;; -help | --help | --hel | --he | -h) ac_init_help=long ;; -help=r* | --help=r* | --hel=r* | --he=r* | -hr*) ac_init_help=recursive ;; -help=s* | --help=s* | --hel=s* | --he=s* | -hs*) ac_init_help=short ;; -host | --host | --hos | --ho) ac_prev=host_alias ;; -host=* | --host=* | --hos=* | --ho=*) host_alias=$ac_optarg ;; -includedir | --includedir | --includedi | --included | --include \ | --includ | --inclu | --incl | --inc) ac_prev=includedir ;; -includedir=* | --includedir=* | --includedi=* | --included=* | --include=* \ | --includ=* | --inclu=* | --incl=* | --inc=*) includedir=$ac_optarg ;; -infodir | --infodir | --infodi | --infod | --info | --inf) ac_prev=infodir ;; -infodir=* | --infodir=* | --infodi=* | --infod=* | --info=* | --inf=*) infodir=$ac_optarg ;; -libdir | --libdir | --libdi | --libd) ac_prev=libdir ;; -libdir=* | --libdir=* | --libdi=* | --libd=*) libdir=$ac_optarg ;; -libexecdir | --libexecdir | --libexecdi | --libexecd | --libexec \ | --libexe | --libex | --libe) ac_prev=libexecdir ;; -libexecdir=* | --libexecdir=* | --libexecdi=* | --libexecd=* | --libexec=* \ | --libexe=* | --libex=* | --libe=*) libexecdir=$ac_optarg ;; -localstatedir | --localstatedir | --localstatedi | --localstated \ | --localstate | --localstat | --localsta | --localst \ | --locals | --local | --loca | --loc | --lo) ac_prev=localstatedir ;; -localstatedir=* | --localstatedir=* | --localstatedi=* | --localstated=* \ | --localstate=* | --localstat=* | --localsta=* | --localst=* \ | --locals=* | --local=* | --loca=* | --loc=* | --lo=*) localstatedir=$ac_optarg ;; -mandir | --mandir | --mandi | --mand | --man | --ma | --m) ac_prev=mandir ;; -mandir=* | --mandir=* | --mandi=* | --mand=* | --man=* | --ma=* | --m=*) mandir=$ac_optarg ;; -nfp | --nfp | --nf) # Obsolete; use --without-fp. with_fp=no ;; -no-create | --no-create | --no-creat | --no-crea | --no-cre \ | --no-cr | --no-c | -n) no_create=yes ;; -no-recursion | --no-recursion | --no-recursio | --no-recursi \ | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r) no_recursion=yes ;; -oldincludedir | --oldincludedir | --oldincludedi | --oldincluded \ | --oldinclude | --oldinclud | --oldinclu | --oldincl | --oldinc \ | --oldin | --oldi | --old | --ol | --o) ac_prev=oldincludedir ;; -oldincludedir=* | --oldincludedir=* | --oldincludedi=* | --oldincluded=* \ | --oldinclude=* | --oldinclud=* | --oldinclu=* | --oldincl=* | --oldinc=* \ | --oldin=* | --oldi=* | --old=* | --ol=* | --o=*) oldincludedir=$ac_optarg ;; -prefix | --prefix | --prefi | --pref | --pre | --pr | --p) ac_prev=prefix ;; -prefix=* | --prefix=* | --prefi=* | --pref=* | --pre=* | --pr=* | --p=*) prefix=$ac_optarg ;; -program-prefix | --program-prefix | --program-prefi | --program-pref \ | --program-pre | --program-pr | --program-p) ac_prev=program_prefix ;; -program-prefix=* | --program-prefix=* | --program-prefi=* \ | --program-pref=* | --program-pre=* | --program-pr=* | --program-p=*) program_prefix=$ac_optarg ;; -program-suffix | --program-suffix | --program-suffi | --program-suff \ | --program-suf | --program-su | --program-s) ac_prev=program_suffix ;; -program-suffix=* | --program-suffix=* | --program-suffi=* \ | --program-suff=* | --program-suf=* | --program-su=* | --program-s=*) program_suffix=$ac_optarg ;; -program-transform-name | --program-transform-name \ | --program-transform-nam | --program-transform-na \ | --program-transform-n | --program-transform- \ | --program-transform | --program-transfor \ | --program-transfo | --program-transf \ | --program-trans | --program-tran \ | --progr-tra | --program-tr | --program-t) ac_prev=program_transform_name ;; -program-transform-name=* | --program-transform-name=* \ | --program-transform-nam=* | --program-transform-na=* \ | --program-transform-n=* | --program-transform-=* \ | --program-transform=* | --program-transfor=* \ | --program-transfo=* | --program-transf=* \ | --program-trans=* | --program-tran=* \ | --progr-tra=* | --program-tr=* | --program-t=*) program_transform_name=$ac_optarg ;; -q | -quiet | --quiet | --quie | --qui | --qu | --q \ | -silent | --silent | --silen | --sile | --sil) silent=yes ;; -sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb) ac_prev=sbindir ;; -sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \ | --sbi=* | --sb=*) sbindir=$ac_optarg ;; -sharedstatedir | --sharedstatedir | --sharedstatedi \ | --sharedstated | --sharedstate | --sharedstat | --sharedsta \ | --sharedst | --shareds | --shared | --share | --shar \ | --sha | --sh) ac_prev=sharedstatedir ;; -sharedstatedir=* | --sharedstatedir=* | --sharedstatedi=* \ | --sharedstated=* | --sharedstate=* | --sharedstat=* | --sharedsta=* \ | --sharedst=* | --shareds=* | --shared=* | --share=* | --shar=* \ | --sha=* | --sh=*) sharedstatedir=$ac_optarg ;; -site | --site | --sit) ac_prev=site ;; -site=* | --site=* | --sit=*) site=$ac_optarg ;; -srcdir | --srcdir | --srcdi | --srcd | --src | --sr) ac_prev=srcdir ;; -srcdir=* | --srcdir=* | --srcdi=* | --srcd=* | --src=* | --sr=*) srcdir=$ac_optarg ;; -sysconfdir | --sysconfdir | --sysconfdi | --sysconfd | --sysconf \ | --syscon | --sysco | --sysc | --sys | --sy) ac_prev=sysconfdir ;; -sysconfdir=* | --sysconfdir=* | --sysconfdi=* | --sysconfd=* | --sysconf=* \ | --syscon=* | --sysco=* | --sysc=* | --sys=* | --sy=*) sysconfdir=$ac_optarg ;; -target | --target | --targe | --targ | --tar | --ta | --t) ac_prev=target_alias ;; -target=* | --target=* | --targe=* | --targ=* | --tar=* | --ta=* | --t=*) target_alias=$ac_optarg ;; -v | -verbose | --verbose | --verbos | --verbo | --verb) verbose=yes ;; -version | --version | --versio | --versi | --vers | -V) ac_init_version=: ;; -with-* | --with-*) ac_package=`expr "x$ac_option" : 'x-*with-\([^=]*\)'` # Reject names that are not valid shell variable names. expr "x$ac_package" : ".*[^-_$as_cr_alnum]" >/dev/null && { echo "$as_me: error: invalid package name: $ac_package" >&2 { (exit 1); exit 1; }; } ac_package=`echo $ac_package| sed 's/-/_/g'` case $ac_option in *=*) ac_optarg=`echo "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"`;; *) ac_optarg=yes ;; esac eval "with_$ac_package='$ac_optarg'" ;; -without-* | --without-*) ac_package=`expr "x$ac_option" : 'x-*without-\(.*\)'` # Reject names that are not valid shell variable names. expr "x$ac_package" : ".*[^-_$as_cr_alnum]" >/dev/null && { echo "$as_me: error: invalid package name: $ac_package" >&2 { (exit 1); exit 1; }; } ac_package=`echo $ac_package | sed 's/-/_/g'` eval "with_$ac_package=no" ;; --x) # Obsolete; use --with-x. with_x=yes ;; -x-includes | --x-includes | --x-include | --x-includ | --x-inclu \ | --x-incl | --x-inc | --x-in | --x-i) ac_prev=x_includes ;; -x-includes=* | --x-includes=* | --x-include=* | --x-includ=* | --x-inclu=* \ | --x-incl=* | --x-inc=* | --x-in=* | --x-i=*) x_includes=$ac_optarg ;; -x-libraries | --x-libraries | --x-librarie | --x-librari \ | --x-librar | --x-libra | --x-libr | --x-lib | --x-li | --x-l) ac_prev=x_libraries ;; -x-libraries=* | --x-libraries=* | --x-librarie=* | --x-librari=* \ | --x-librar=* | --x-libra=* | --x-libr=* | --x-lib=* | --x-li=* | --x-l=*) x_libraries=$ac_optarg ;; -*) { echo "$as_me: error: unrecognized option: $ac_option Try \`$0 --help' for more information." >&2 { (exit 1); exit 1; }; } ;; *=*) ac_envvar=`expr "x$ac_option" : 'x\([^=]*\)='` # Reject names that are not valid shell variable names. expr "x$ac_envvar" : ".*[^_$as_cr_alnum]" >/dev/null && { echo "$as_me: error: invalid variable name: $ac_envvar" >&2 { (exit 1); exit 1; }; } ac_optarg=`echo "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"` eval "$ac_envvar='$ac_optarg'" export $ac_envvar ;; *) # FIXME: should be removed in autoconf 3.0. echo "$as_me: WARNING: you should use --build, --host, --target" >&2 expr "x$ac_option" : ".*[^-._$as_cr_alnum]" >/dev/null && echo "$as_me: WARNING: invalid host type: $ac_option" >&2 : ${build_alias=$ac_option} ${host_alias=$ac_option} ${target_alias=$ac_option} ;; esac done if test -n "$ac_prev"; then ac_option=--`echo $ac_prev | sed 's/_/-/g'` { echo "$as_me: error: missing argument to $ac_option" >&2 { (exit 1); exit 1; }; } fi # Be sure to have absolute paths. for ac_var in exec_prefix prefix do eval ac_val=$`echo $ac_var` case $ac_val in [\\/$]* | ?:[\\/]* | NONE | '' ) ;; *) { echo "$as_me: error: expected an absolute directory name for --$ac_var: $ac_val" >&2 { (exit 1); exit 1; }; };; esac done # Be sure to have absolute paths. for ac_var in bindir sbindir libexecdir datadir sysconfdir sharedstatedir \ localstatedir libdir includedir oldincludedir infodir mandir do eval ac_val=$`echo $ac_var` case $ac_val in [\\/$]* | ?:[\\/]* ) ;; *) { echo "$as_me: error: expected an absolute directory name for --$ac_var: $ac_val" >&2 { (exit 1); exit 1; }; };; esac done # There might be people who depend on the old broken behavior: `$host' # used to hold the argument of --host etc. # FIXME: To remove some day. build=$build_alias host=$host_alias target=$target_alias # FIXME: To remove some day. if test "x$host_alias" != x; then if test "x$build_alias" = x; then cross_compiling=maybe echo "$as_me: WARNING: If you wanted to set the --build type, don't use --host. If a cross compiler is detected then cross compile mode will be used." >&2 elif test "x$build_alias" != "x$host_alias"; then cross_compiling=yes fi fi ac_tool_prefix= test -n "$host_alias" && ac_tool_prefix=$host_alias- test "$silent" = yes && exec 6>/dev/null # Find the source files, if location was not specified. if test -z "$srcdir"; then ac_srcdir_defaulted=yes # Try the directory containing this script, then its parent. ac_confdir=`(dirname "$0") 2>/dev/null || $as_expr X"$0" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$0" : 'X\(//\)[^/]' \| \ X"$0" : 'X\(//\)$' \| \ X"$0" : 'X\(/\)' \| \ . : '\(.\)' 2>/dev/null || echo X"$0" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/; q; } /^X\(\/\/\)[^/].*/{ s//\1/; q; } /^X\(\/\/\)$/{ s//\1/; q; } /^X\(\/\).*/{ s//\1/; q; } s/.*/./; q'` srcdir=$ac_confdir if test ! -r $srcdir/$ac_unique_file; then srcdir=.. fi else ac_srcdir_defaulted=no fi if test ! -r $srcdir/$ac_unique_file; then if test "$ac_srcdir_defaulted" = yes; then { echo "$as_me: error: cannot find sources ($ac_unique_file) in $ac_confdir or .." >&2 { (exit 1); exit 1; }; } else { echo "$as_me: error: cannot find sources ($ac_unique_file) in $srcdir" >&2 { (exit 1); exit 1; }; } fi fi (cd $srcdir && test -r ./$ac_unique_file) 2>/dev/null || { echo "$as_me: error: sources are in $srcdir, but \`cd $srcdir' does not work" >&2 { (exit 1); exit 1; }; } srcdir=`echo "$srcdir" | sed 's%\([^\\/]\)[\\/]*$%\1%'` ac_env_build_alias_set=${build_alias+set} ac_env_build_alias_value=$build_alias ac_cv_env_build_alias_set=${build_alias+set} ac_cv_env_build_alias_value=$build_alias ac_env_host_alias_set=${host_alias+set} ac_env_host_alias_value=$host_alias ac_cv_env_host_alias_set=${host_alias+set} ac_cv_env_host_alias_value=$host_alias ac_env_target_alias_set=${target_alias+set} ac_env_target_alias_value=$target_alias ac_cv_env_target_alias_set=${target_alias+set} ac_cv_env_target_alias_value=$target_alias ac_env_CC_set=${CC+set} ac_env_CC_value=$CC ac_cv_env_CC_set=${CC+set} ac_cv_env_CC_value=$CC ac_env_CFLAGS_set=${CFLAGS+set} ac_env_CFLAGS_value=$CFLAGS ac_cv_env_CFLAGS_set=${CFLAGS+set} ac_cv_env_CFLAGS_value=$CFLAGS ac_env_LDFLAGS_set=${LDFLAGS+set} ac_env_LDFLAGS_value=$LDFLAGS ac_cv_env_LDFLAGS_set=${LDFLAGS+set} ac_cv_env_LDFLAGS_value=$LDFLAGS ac_env_CPPFLAGS_set=${CPPFLAGS+set} ac_env_CPPFLAGS_value=$CPPFLAGS ac_cv_env_CPPFLAGS_set=${CPPFLAGS+set} ac_cv_env_CPPFLAGS_value=$CPPFLAGS ac_env_CPP_set=${CPP+set} ac_env_CPP_value=$CPP ac_cv_env_CPP_set=${CPP+set} ac_cv_env_CPP_value=$CPP # # Report the --help message. # if test "$ac_init_help" = "long"; then # Omit some internal or obsolete options to make the list less imposing. # This message is too long to be a string in the A/UX 3.1 sh. cat <<_ACEOF \`configure' configures tclx 8.4 to adapt to many kinds of systems. Usage: $0 [OPTION]... [VAR=VALUE]... To assign environment variables (e.g., CC, CFLAGS...), specify them as VAR=VALUE. See below for descriptions of some of the useful variables. Defaults for the options are specified in brackets. Configuration: -h, --help display this help and exit --help=short display options specific to this package --help=recursive display the short help of all the included packages -V, --version display version information and exit -q, --quiet, --silent do not print \`checking...' messages --cache-file=FILE cache test results in FILE [disabled] -C, --config-cache alias for \`--cache-file=config.cache' -n, --no-create do not create output files --srcdir=DIR find the sources in DIR [configure dir or \`..'] _ACEOF cat <<_ACEOF Installation directories: --prefix=PREFIX install architecture-independent files in PREFIX [$ac_default_prefix] --exec-prefix=EPREFIX install architecture-dependent files in EPREFIX [PREFIX] By default, \`make install' will install all the files in \`$ac_default_prefix/bin', \`$ac_default_prefix/lib' etc. You can specify an installation prefix other than \`$ac_default_prefix' using \`--prefix', for instance \`--prefix=\$HOME'. For better control, use the options below. Fine tuning of the installation directories: --bindir=DIR user executables [EPREFIX/bin] --sbindir=DIR system admin executables [EPREFIX/sbin] --libexecdir=DIR program executables [EPREFIX/libexec] --datadir=DIR read-only architecture-independent data [PREFIX/share] --sysconfdir=DIR read-only single-machine data [PREFIX/etc] --sharedstatedir=DIR modifiable architecture-independent data [PREFIX/com] --localstatedir=DIR modifiable single-machine data [PREFIX/var] --libdir=DIR object code libraries [EPREFIX/lib] --includedir=DIR C header files [PREFIX/include] --oldincludedir=DIR C header files for non-gcc [/usr/include] --infodir=DIR info documentation [PREFIX/info] --mandir=DIR man documentation [PREFIX/man] _ACEOF cat <<\_ACEOF _ACEOF fi if test -n "$ac_init_help"; then case $ac_init_help in short | recursive ) echo "Configuration of tclx 8.4:";; esac cat <<\_ACEOF Optional Features: --disable-FEATURE do not include FEATURE (same as --enable-FEATURE=no) --enable-FEATURE[=ARG] include FEATURE [ARG=yes] --enable-threads build with threads --enable-shared build and link with shared libraries (default: on) --enable-64bit enable 64bit support (default: off) --enable-64bit-vis enable 64bit Sparc VIS support (default: off) --enable-wince enable Win/CE support (where applicable) --disable-load disallow dynamic loading and "load" command (default: enabled) --enable-symbols build with debugging symbols (default: off) Optional Packages: --with-PACKAGE[=ARG] use PACKAGE [ARG=yes] --without-PACKAGE do not use PACKAGE (same as --with-PACKAGE=no) --with-tcl directory containing tcl configuration (tclConfig.sh) --with-celib=DIR use Windows/CE support library from DIR --with-help directory containing generated help files Some influential environment variables: CC C compiler command CFLAGS C compiler flags LDFLAGS linker flags, e.g. -L if you have libraries in a nonstandard directory CPPFLAGS C/C++ preprocessor flags, e.g. -I if you have headers in a nonstandard directory CPP C preprocessor Use these variables to override the choices made by `configure' or to help it to find libraries and programs with nonstandard names/locations. _ACEOF fi if test "$ac_init_help" = "recursive"; then # If there are subdirs, report their specific --help. ac_popdir=`pwd` for ac_dir in : $ac_subdirs_all; do test "x$ac_dir" = x: && continue test -d $ac_dir || continue ac_builddir=. if test "$ac_dir" != .; then ac_dir_suffix=/`echo "$ac_dir" | sed 's,^\.[\\/],,'` # A "../" for each directory in $ac_dir_suffix. ac_top_builddir=`echo "$ac_dir_suffix" | sed 's,/[^\\/]*,../,g'` else ac_dir_suffix= ac_top_builddir= fi case $srcdir in .) # No --srcdir option. We are building in place. ac_srcdir=. if test -z "$ac_top_builddir"; then ac_top_srcdir=. else ac_top_srcdir=`echo $ac_top_builddir | sed 's,/$,,'` fi ;; [\\/]* | ?:[\\/]* ) # Absolute path. ac_srcdir=$srcdir$ac_dir_suffix; ac_top_srcdir=$srcdir ;; *) # Relative path. ac_srcdir=$ac_top_builddir$srcdir$ac_dir_suffix ac_top_srcdir=$ac_top_builddir$srcdir ;; esac # Do not use `cd foo && pwd` to compute absolute paths, because # the directories may not exist. case `pwd` in .) ac_abs_builddir="$ac_dir";; *) case "$ac_dir" in .) ac_abs_builddir=`pwd`;; [\\/]* | ?:[\\/]* ) ac_abs_builddir="$ac_dir";; *) ac_abs_builddir=`pwd`/"$ac_dir";; esac;; esac case $ac_abs_builddir in .) ac_abs_top_builddir=${ac_top_builddir}.;; *) case ${ac_top_builddir}. in .) ac_abs_top_builddir=$ac_abs_builddir;; [\\/]* | ?:[\\/]* ) ac_abs_top_builddir=${ac_top_builddir}.;; *) ac_abs_top_builddir=$ac_abs_builddir/${ac_top_builddir}.;; esac;; esac case $ac_abs_builddir in .) ac_abs_srcdir=$ac_srcdir;; *) case $ac_srcdir in .) ac_abs_srcdir=$ac_abs_builddir;; [\\/]* | ?:[\\/]* ) ac_abs_srcdir=$ac_srcdir;; *) ac_abs_srcdir=$ac_abs_builddir/$ac_srcdir;; esac;; esac case $ac_abs_builddir in .) ac_abs_top_srcdir=$ac_top_srcdir;; *) case $ac_top_srcdir in .) ac_abs_top_srcdir=$ac_abs_builddir;; [\\/]* | ?:[\\/]* ) ac_abs_top_srcdir=$ac_top_srcdir;; *) ac_abs_top_srcdir=$ac_abs_builddir/$ac_top_srcdir;; esac;; esac cd $ac_dir # Check for guested configure; otherwise get Cygnus style configure. if test -f $ac_srcdir/configure.gnu; then echo $SHELL $ac_srcdir/configure.gnu --help=recursive elif test -f $ac_srcdir/configure; then echo $SHELL $ac_srcdir/configure --help=recursive elif test -f $ac_srcdir/configure.ac || test -f $ac_srcdir/configure.in; then echo $ac_configure --help else echo "$as_me: WARNING: no configuration information is in $ac_dir" >&2 fi cd $ac_popdir done fi test -n "$ac_init_help" && exit 0 if $ac_init_version; then cat <<\_ACEOF tclx configure 8.4 generated by GNU Autoconf 2.59 Copyright (C) 2003 Free Software Foundation, Inc. This configure script is free software; the Free Software Foundation gives unlimited permission to copy, distribute and modify it. _ACEOF exit 0 fi exec 5>config.log cat >&5 <<_ACEOF This file contains any messages produced by compilers while running configure, to aid debugging if configure makes a mistake. It was created by tclx $as_me 8.4, which was generated by GNU Autoconf 2.59. Invocation command line was $ $0 $@ _ACEOF { cat <<_ASUNAME ## --------- ## ## Platform. ## ## --------- ## hostname = `(hostname || uname -n) 2>/dev/null | sed 1q` uname -m = `(uname -m) 2>/dev/null || echo unknown` uname -r = `(uname -r) 2>/dev/null || echo unknown` uname -s = `(uname -s) 2>/dev/null || echo unknown` uname -v = `(uname -v) 2>/dev/null || echo unknown` /usr/bin/uname -p = `(/usr/bin/uname -p) 2>/dev/null || echo unknown` /bin/uname -X = `(/bin/uname -X) 2>/dev/null || echo unknown` /bin/arch = `(/bin/arch) 2>/dev/null || echo unknown` /usr/bin/arch -k = `(/usr/bin/arch -k) 2>/dev/null || echo unknown` /usr/convex/getsysinfo = `(/usr/convex/getsysinfo) 2>/dev/null || echo unknown` hostinfo = `(hostinfo) 2>/dev/null || echo unknown` /bin/machine = `(/bin/machine) 2>/dev/null || echo unknown` /usr/bin/oslevel = `(/usr/bin/oslevel) 2>/dev/null || echo unknown` /bin/universe = `(/bin/universe) 2>/dev/null || echo unknown` _ASUNAME as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. echo "PATH: $as_dir" done } >&5 cat >&5 <<_ACEOF ## ----------- ## ## Core tests. ## ## ----------- ## _ACEOF # Keep a trace of the command line. # Strip out --no-create and --no-recursion so they do not pile up. # Strip out --silent because we don't want to record it for future runs. # Also quote any args containing shell meta-characters. # Make two passes to allow for proper duplicate-argument suppression. ac_configure_args= ac_configure_args0= ac_configure_args1= ac_sep= ac_must_keep_next=false for ac_pass in 1 2 do for ac_arg do case $ac_arg in -no-create | --no-c* | -n | -no-recursion | --no-r*) continue ;; -q | -quiet | --quiet | --quie | --qui | --qu | --q \ | -silent | --silent | --silen | --sile | --sil) continue ;; *" "*|*" "*|*[\[\]\~\#\$\^\&\*\(\)\{\}\\\|\;\<\>\?\"\']*) ac_arg=`echo "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;; esac case $ac_pass in 1) ac_configure_args0="$ac_configure_args0 '$ac_arg'" ;; 2) ac_configure_args1="$ac_configure_args1 '$ac_arg'" if test $ac_must_keep_next = true; then ac_must_keep_next=false # Got value, back to normal. else case $ac_arg in *=* | --config-cache | -C | -disable-* | --disable-* \ | -enable-* | --enable-* | -gas | --g* | -nfp | --nf* \ | -q | -quiet | --q* | -silent | --sil* | -v | -verb* \ | -with-* | --with-* | -without-* | --without-* | --x) case "$ac_configure_args0 " in "$ac_configure_args1"*" '$ac_arg' "* ) continue ;; esac ;; -* ) ac_must_keep_next=true ;; esac fi ac_configure_args="$ac_configure_args$ac_sep'$ac_arg'" # Get rid of the leading space. ac_sep=" " ;; esac done done $as_unset ac_configure_args0 || test "${ac_configure_args0+set}" != set || { ac_configure_args0=; export ac_configure_args0; } $as_unset ac_configure_args1 || test "${ac_configure_args1+set}" != set || { ac_configure_args1=; export ac_configure_args1; } # When interrupted or exit'd, cleanup temporary files, and complete # config.log. We remove comments because anyway the quotes in there # would cause problems or look ugly. # WARNING: Be sure not to use single quotes in there, as some shells, # such as our DU 5.0 friend, will then `close' the trap. trap 'exit_status=$? # Save into config.log some information that might help in debugging. { echo cat <<\_ASBOX ## ---------------- ## ## Cache variables. ## ## ---------------- ## _ASBOX echo # The following way of writing the cache mishandles newlines in values, { (set) 2>&1 | case `(ac_space='"'"' '"'"'; set | grep ac_space) 2>&1` in *ac_space=\ *) sed -n \ "s/'"'"'/'"'"'\\\\'"'"''"'"'/g; s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='"'"'\\2'"'"'/p" ;; *) sed -n \ "s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1=\\2/p" ;; esac; } echo cat <<\_ASBOX ## ----------------- ## ## Output variables. ## ## ----------------- ## _ASBOX echo for ac_var in $ac_subst_vars do eval ac_val=$`echo $ac_var` echo "$ac_var='"'"'$ac_val'"'"'" done | sort echo if test -n "$ac_subst_files"; then cat <<\_ASBOX ## ------------- ## ## Output files. ## ## ------------- ## _ASBOX echo for ac_var in $ac_subst_files do eval ac_val=$`echo $ac_var` echo "$ac_var='"'"'$ac_val'"'"'" done | sort echo fi if test -s confdefs.h; then cat <<\_ASBOX ## ----------- ## ## confdefs.h. ## ## ----------- ## _ASBOX echo sed "/^$/d" confdefs.h | sort echo fi test "$ac_signal" != 0 && echo "$as_me: caught signal $ac_signal" echo "$as_me: exit $exit_status" } >&5 rm -f core *.core && rm -rf conftest* confdefs* conf$$* $ac_clean_files && exit $exit_status ' 0 for ac_signal in 1 2 13 15; do trap 'ac_signal='$ac_signal'; { (exit 1); exit 1; }' $ac_signal done ac_signal=0 # confdefs.h avoids OS command line length limits that DEFS can exceed. rm -rf conftest* confdefs.h # AIX cpp loses on an empty file, so make sure it contains at least a newline. echo >confdefs.h # Predefined preprocessor variables. cat >>confdefs.h <<_ACEOF #define PACKAGE_NAME "$PACKAGE_NAME" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_TARNAME "$PACKAGE_TARNAME" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_VERSION "$PACKAGE_VERSION" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_STRING "$PACKAGE_STRING" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_BUGREPORT "$PACKAGE_BUGREPORT" _ACEOF # Let the site file select an alternate cache file if it wants to. # Prefer explicitly selected file to automatically selected ones. if test -z "$CONFIG_SITE"; then if test "x$prefix" != xNONE; then CONFIG_SITE="$prefix/share/config.site $prefix/etc/config.site" else CONFIG_SITE="$ac_default_prefix/share/config.site $ac_default_prefix/etc/config.site" fi fi for ac_site_file in $CONFIG_SITE; do if test -r "$ac_site_file"; then { echo "$as_me:$LINENO: loading site script $ac_site_file" >&5 echo "$as_me: loading site script $ac_site_file" >&6;} sed 's/^/| /' "$ac_site_file" >&5 . "$ac_site_file" fi done if test -r "$cache_file"; then # Some versions of bash will fail to source /dev/null (special # files actually), so we avoid doing that. if test -f "$cache_file"; then { echo "$as_me:$LINENO: loading cache $cache_file" >&5 echo "$as_me: loading cache $cache_file" >&6;} case $cache_file in [\\/]* | ?:[\\/]* ) . $cache_file;; *) . ./$cache_file;; esac fi else { echo "$as_me:$LINENO: creating cache $cache_file" >&5 echo "$as_me: creating cache $cache_file" >&6;} >$cache_file fi # Check that the precious variables saved in the cache have kept the same # value. ac_cache_corrupted=false for ac_var in `(set) 2>&1 | sed -n 's/^ac_env_\([a-zA-Z_0-9]*\)_set=.*/\1/p'`; do eval ac_old_set=\$ac_cv_env_${ac_var}_set eval ac_new_set=\$ac_env_${ac_var}_set eval ac_old_val="\$ac_cv_env_${ac_var}_value" eval ac_new_val="\$ac_env_${ac_var}_value" case $ac_old_set,$ac_new_set in set,) { echo "$as_me:$LINENO: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&5 echo "$as_me: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&2;} ac_cache_corrupted=: ;; ,set) { echo "$as_me:$LINENO: error: \`$ac_var' was not set in the previous run" >&5 echo "$as_me: error: \`$ac_var' was not set in the previous run" >&2;} ac_cache_corrupted=: ;; ,);; *) if test "x$ac_old_val" != "x$ac_new_val"; then { echo "$as_me:$LINENO: error: \`$ac_var' has changed since the previous run:" >&5 echo "$as_me: error: \`$ac_var' has changed since the previous run:" >&2;} { echo "$as_me:$LINENO: former value: $ac_old_val" >&5 echo "$as_me: former value: $ac_old_val" >&2;} { echo "$as_me:$LINENO: current value: $ac_new_val" >&5 echo "$as_me: current value: $ac_new_val" >&2;} ac_cache_corrupted=: fi;; esac # Pass precious variables to config.status. if test "$ac_new_set" = set; then case $ac_new_val in *" "*|*" "*|*[\[\]\~\#\$\^\&\*\(\)\{\}\\\|\;\<\>\?\"\']*) ac_arg=$ac_var=`echo "$ac_new_val" | sed "s/'/'\\\\\\\\''/g"` ;; *) ac_arg=$ac_var=$ac_new_val ;; esac case " $ac_configure_args " in *" '$ac_arg' "*) ;; # Avoid dups. Use of quotes ensures accuracy. *) ac_configure_args="$ac_configure_args '$ac_arg'" ;; esac fi done if $ac_cache_corrupted; then { echo "$as_me:$LINENO: error: changes in the environment can compromise the build" >&5 echo "$as_me: error: changes in the environment can compromise the build" >&2;} { { echo "$as_me:$LINENO: error: run \`make distclean' and/or \`rm $cache_file' and start over" >&5 echo "$as_me: error: run \`make distclean' and/or \`rm $cache_file' and start over" >&2;} { (exit 1); exit 1; }; } fi ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu FULL_VERSION="8.4.1" # TEA extensions pass this us the version of TEA they think they # are compatible with. TEA_VERSION="3.5" echo "$as_me:$LINENO: checking for correct TEA configuration" >&5 echo $ECHO_N "checking for correct TEA configuration... $ECHO_C" >&6 if test x"${PACKAGE_NAME}" = x ; then { { echo "$as_me:$LINENO: error: The PACKAGE_NAME variable must be defined by your TEA configure.in" >&5 echo "$as_me: error: The PACKAGE_NAME variable must be defined by your TEA configure.in" >&2;} { (exit 1); exit 1; }; } fi if test x"3.5" = x ; then { { echo "$as_me:$LINENO: error: TEA version not specified." >&5 echo "$as_me: error: TEA version not specified." >&2;} { (exit 1); exit 1; }; } elif test "3.5" != "${TEA_VERSION}" ; then echo "$as_me:$LINENO: result: warning: requested TEA version \"3.5\", have \"${TEA_VERSION}\"" >&5 echo "${ECHO_T}warning: requested TEA version \"3.5\", have \"${TEA_VERSION}\"" >&6 else echo "$as_me:$LINENO: result: ok (TEA ${TEA_VERSION})" >&5 echo "${ECHO_T}ok (TEA ${TEA_VERSION})" >&6 fi case "`uname -s`" in *win32*|*WIN32*|*CYGWIN_NT*|*CYGWIN_9*|*CYGWIN_ME*|*MINGW32_*) # Extract the first word of "cygpath", so it can be a program name with args. set dummy cygpath; ac_word=$2 echo "$as_me:$LINENO: checking for $ac_word" >&5 echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 if test "${ac_cv_prog_CYGPATH+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else if test -n "$CYGPATH"; then ac_cv_prog_CYGPATH="$CYGPATH" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_CYGPATH="cygpath -w" echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done test -z "$ac_cv_prog_CYGPATH" && ac_cv_prog_CYGPATH="echo" fi fi CYGPATH=$ac_cv_prog_CYGPATH if test -n "$CYGPATH"; then echo "$as_me:$LINENO: result: $CYGPATH" >&5 echo "${ECHO_T}$CYGPATH" >&6 else echo "$as_me:$LINENO: result: no" >&5 echo "${ECHO_T}no" >&6 fi EXEEXT=".exe" TEA_PLATFORM="windows" ;; *) CYGPATH=echo EXEEXT="" TEA_PLATFORM="unix" ;; esac # Check if exec_prefix is set. If not use fall back to prefix. # Note when adjusted, so that TEA_PREFIX can correct for this. # This is needed for recursive configures, since autoconf propagates # $prefix, but not $exec_prefix (doh!). if test x$exec_prefix = xNONE ; then exec_prefix_default=yes exec_prefix=$prefix fi # This package name must be replaced statically for AC_SUBST to work # Substitute STUB_LIB_FILE in case package creates a stub library too. # We AC_SUBST these here to ensure they are subst'ed, # in case the user doesn't call TEA_ADD_... ac_aux_dir= for ac_dir in tclconfig $srcdir/tclconfig; do if test -f $ac_dir/install-sh; then ac_aux_dir=$ac_dir ac_install_sh="$ac_aux_dir/install-sh -c" break elif test -f $ac_dir/install.sh; then ac_aux_dir=$ac_dir ac_install_sh="$ac_aux_dir/install.sh -c" break elif test -f $ac_dir/shtool; then ac_aux_dir=$ac_dir ac_install_sh="$ac_aux_dir/shtool install -c" break fi done if test -z "$ac_aux_dir"; then { { echo "$as_me:$LINENO: error: cannot find install-sh or install.sh in tclconfig $srcdir/tclconfig" >&5 echo "$as_me: error: cannot find install-sh or install.sh in tclconfig $srcdir/tclconfig" >&2;} { (exit 1); exit 1; }; } fi ac_config_guess="$SHELL $ac_aux_dir/config.guess" ac_config_sub="$SHELL $ac_aux_dir/config.sub" ac_configure="$SHELL $ac_aux_dir/configure" # This should be Cygnus configure. cat >>confdefs.h <<_ACEOF #define FULL_VERSION "${FULL_VERSION}" _ACEOF #-------------------------------------------------------------------- # Load the tclConfig.sh file #-------------------------------------------------------------------- # # Ok, lets find the tcl configuration # First, look for one uninstalled. # the alternative search directory is invoked by --with-tcl # if test x"${no_tcl}" = x ; then # we reset no_tcl in case something fails here no_tcl=true # Check whether --with-tcl or --without-tcl was given. if test "${with_tcl+set}" = set; then withval="$with_tcl" with_tclconfig=${withval} fi; echo "$as_me:$LINENO: checking for Tcl configuration" >&5 echo $ECHO_N "checking for Tcl configuration... $ECHO_C" >&6 if test "${ac_cv_c_tclconfig+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else # First check to see if --with-tcl was specified. if test x"${with_tclconfig}" != x ; then case ${with_tclconfig} in */tclConfig.sh ) if test -f ${with_tclconfig}; then { echo "$as_me:$LINENO: WARNING: --with-tcl argument should refer to directory containing tclConfig.sh, not to tclConfig.sh itself" >&5 echo "$as_me: WARNING: --with-tcl argument should refer to directory containing tclConfig.sh, not to tclConfig.sh itself" >&2;} with_tclconfig=`echo ${with_tclconfig} | sed 's!/tclConfig\.sh$!!'` fi ;; esac if test -f "${with_tclconfig}/tclConfig.sh" ; then ac_cv_c_tclconfig=`(cd ${with_tclconfig}; pwd)` else { { echo "$as_me:$LINENO: error: ${with_tclconfig} directory doesn't contain tclConfig.sh" >&5 echo "$as_me: error: ${with_tclconfig} directory doesn't contain tclConfig.sh" >&2;} { (exit 1); exit 1; }; } fi fi # then check for a private Tcl installation if test x"${ac_cv_c_tclconfig}" = x ; then for i in \ ../tcl \ `ls -dr ../tcl[8-9].[0-9].[0-9]* 2>/dev/null` \ `ls -dr ../tcl[8-9].[0-9] 2>/dev/null` \ `ls -dr ../tcl[8-9].[0-9]* 2>/dev/null` \ ../../tcl \ `ls -dr ../../tcl[8-9].[0-9].[0-9]* 2>/dev/null` \ `ls -dr ../../tcl[8-9].[0-9] 2>/dev/null` \ `ls -dr ../../tcl[8-9].[0-9]* 2>/dev/null` \ ../../../tcl \ `ls -dr ../../../tcl[8-9].[0-9].[0-9]* 2>/dev/null` \ `ls -dr ../../../tcl[8-9].[0-9] 2>/dev/null` \ `ls -dr ../../../tcl[8-9].[0-9]* 2>/dev/null` ; do if test -f "$i/unix/tclConfig.sh" ; then ac_cv_c_tclconfig=`(cd $i/unix; pwd)` break fi done fi # on Darwin, check in Framework installation locations if test "`uname -s`" = "Darwin" -a x"${ac_cv_c_tclconfig}" = x ; then for i in `ls -d ~/Library/Frameworks 2>/dev/null` \ `ls -d /Library/Frameworks 2>/dev/null` \ `ls -d /Network/Library/Frameworks 2>/dev/null` \ `ls -d /System/Library/Frameworks 2>/dev/null` \ ; do if test -f "$i/Tcl.framework/tclConfig.sh" ; then ac_cv_c_tclconfig=`(cd $i/Tcl.framework; pwd)` break fi done fi # on Windows, check in common installation locations if test "${TEA_PLATFORM}" = "windows" \ -a x"${ac_cv_c_tclconfig}" = x ; then for i in `ls -d C:/Tcl/lib 2>/dev/null` \ `ls -d C:/Progra~1/Tcl/lib 2>/dev/null` \ ; do if test -f "$i/tclConfig.sh" ; then ac_cv_c_tclconfig=`(cd $i; pwd)` break fi done fi # check in a few common install locations if test x"${ac_cv_c_tclconfig}" = x ; then for i in `ls -d ${libdir} 2>/dev/null` \ `ls -d ${exec_prefix}/lib 2>/dev/null` \ `ls -d ${prefix}/lib 2>/dev/null` \ `ls -d /usr/local/lib 2>/dev/null` \ `ls -d /usr/contrib/lib 2>/dev/null` \ `ls -d /usr/lib 2>/dev/null` \ ; do if test -f "$i/tclConfig.sh" ; then ac_cv_c_tclconfig=`(cd $i; pwd)` break fi done fi # check in a few other private locations if test x"${ac_cv_c_tclconfig}" = x ; then for i in \ ${srcdir}/../tcl \ `ls -dr ${srcdir}/../tcl[8-9].[0-9].[0-9]* 2>/dev/null` \ `ls -dr ${srcdir}/../tcl[8-9].[0-9] 2>/dev/null` \ `ls -dr ${srcdir}/../tcl[8-9].[0-9]* 2>/dev/null` ; do if test -f "$i/unix/tclConfig.sh" ; then ac_cv_c_tclconfig=`(cd $i/unix; pwd)` break fi done fi fi if test x"${ac_cv_c_tclconfig}" = x ; then TCL_BIN_DIR="# no Tcl configs found" { echo "$as_me:$LINENO: WARNING: Can't find Tcl configuration definitions" >&5 echo "$as_me: WARNING: Can't find Tcl configuration definitions" >&2;} exit 0 else no_tcl= TCL_BIN_DIR=${ac_cv_c_tclconfig} echo "$as_me:$LINENO: result: found ${TCL_BIN_DIR}/tclConfig.sh" >&5 echo "${ECHO_T}found ${TCL_BIN_DIR}/tclConfig.sh" >&6 fi fi echo "$as_me:$LINENO: checking for existence of ${TCL_BIN_DIR}/tclConfig.sh" >&5 echo $ECHO_N "checking for existence of ${TCL_BIN_DIR}/tclConfig.sh... $ECHO_C" >&6 if test -f "${TCL_BIN_DIR}/tclConfig.sh" ; then echo "$as_me:$LINENO: result: loading" >&5 echo "${ECHO_T}loading" >&6 . ${TCL_BIN_DIR}/tclConfig.sh else echo "$as_me:$LINENO: result: could not find ${TCL_BIN_DIR}/tclConfig.sh" >&5 echo "${ECHO_T}could not find ${TCL_BIN_DIR}/tclConfig.sh" >&6 fi # eval is required to do the TCL_DBGX substitution eval "TCL_LIB_FILE=\"${TCL_LIB_FILE}\"" eval "TCL_STUB_LIB_FILE=\"${TCL_STUB_LIB_FILE}\"" # If the TCL_BIN_DIR is the build directory (not the install directory), # then set the common variable name to the value of the build variables. # For example, the variable TCL_LIB_SPEC will be set to the value # of TCL_BUILD_LIB_SPEC. An extension should make use of TCL_LIB_SPEC # instead of TCL_BUILD_LIB_SPEC since it will work with both an # installed and uninstalled version of Tcl. if test -f ${TCL_BIN_DIR}/Makefile ; then TCL_LIB_SPEC=${TCL_BUILD_LIB_SPEC} TCL_STUB_LIB_SPEC=${TCL_BUILD_STUB_LIB_SPEC} TCL_STUB_LIB_PATH=${TCL_BUILD_STUB_LIB_PATH} elif test "`uname -s`" = "Darwin"; then # If Tcl was built as a framework, attempt to use the libraries # from the framework at the given location so that linking works # against Tcl.framework installed in an arbitary location. case ${TCL_DEFS} in *TCL_FRAMEWORK*) if test -f ${TCL_BIN_DIR}/${TCL_LIB_FILE}; then for i in "`cd ${TCL_BIN_DIR}; pwd`" \ "`cd ${TCL_BIN_DIR}/../..; pwd`"; do if test "`basename "$i"`" = "${TCL_LIB_FILE}.framework"; then TCL_LIB_SPEC="-F`dirname "$i"` -framework ${TCL_LIB_FILE}" break fi done fi if test -f ${TCL_BIN_DIR}/${TCL_STUB_LIB_FILE}; then TCL_STUB_LIB_SPEC="-L${TCL_BIN_DIR} ${TCL_STUB_LIB_FLAG}" TCL_STUB_LIB_PATH="${TCL_BIN_DIR}/${TCL_STUB_LIB_FILE}" fi ;; esac fi # eval is required to do the TCL_DBGX substitution eval "TCL_LIB_FLAG=\"${TCL_LIB_FLAG}\"" eval "TCL_LIB_SPEC=\"${TCL_LIB_SPEC}\"" eval "TCL_STUB_LIB_FLAG=\"${TCL_STUB_LIB_FLAG}\"" eval "TCL_STUB_LIB_SPEC=\"${TCL_STUB_LIB_SPEC}\"" #----------------------------------------------------------------------- # Handle the --prefix=... option by defaulting to what Tcl gave. # Must be called after TEA_LOAD_TCLCONFIG and before TEA_SETUP_COMPILER. #----------------------------------------------------------------------- if test "${prefix}" = "NONE"; then prefix_default=yes if test x"${TCL_PREFIX}" != x; then { echo "$as_me:$LINENO: --prefix defaulting to TCL_PREFIX ${TCL_PREFIX}" >&5 echo "$as_me: --prefix defaulting to TCL_PREFIX ${TCL_PREFIX}" >&6;} prefix=${TCL_PREFIX} else { echo "$as_me:$LINENO: --prefix defaulting to /usr/local" >&5 echo "$as_me: --prefix defaulting to /usr/local" >&6;} prefix=/usr/local fi fi if test "${exec_prefix}" = "NONE" -a x"${prefix_default}" = x"yes" \ -o x"${exec_prefix_default}" = x"yes" ; then if test x"${TCL_EXEC_PREFIX}" != x; then { echo "$as_me:$LINENO: --exec-prefix defaulting to TCL_EXEC_PREFIX ${TCL_EXEC_PREFIX}" >&5 echo "$as_me: --exec-prefix defaulting to TCL_EXEC_PREFIX ${TCL_EXEC_PREFIX}" >&6;} exec_prefix=${TCL_EXEC_PREFIX} else { echo "$as_me:$LINENO: --exec-prefix defaulting to ${prefix}" >&5 echo "$as_me: --exec-prefix defaulting to ${prefix}" >&6;} exec_prefix=$prefix fi fi #----------------------------------------------------------------------- # Standard compiler checks. # This sets up CC by using the CC env var, or looks for gcc otherwise. # This also calls AC_PROG_CC, AC_PROG_INSTALL and a few others to create # the basic setup necessary to compile executables. #----------------------------------------------------------------------- # Don't put any macros that use the compiler (e.g. AC_TRY_COMPILE) # in this macro, they need to go into TEA_SETUP_COMPILER instead. # If the user did not set CFLAGS, set it now to keep # the AC_PROG_CC macro from adding "-g -O2". if test "${CFLAGS+set}" != "set" ; then CFLAGS="" fi ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu if test -n "$ac_tool_prefix"; then # Extract the first word of "${ac_tool_prefix}gcc", so it can be a program name with args. set dummy ${ac_tool_prefix}gcc; ac_word=$2 echo "$as_me:$LINENO: checking for $ac_word" >&5 echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 if test "${ac_cv_prog_CC+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_CC="${ac_tool_prefix}gcc" echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done fi fi CC=$ac_cv_prog_CC if test -n "$CC"; then echo "$as_me:$LINENO: result: $CC" >&5 echo "${ECHO_T}$CC" >&6 else echo "$as_me:$LINENO: result: no" >&5 echo "${ECHO_T}no" >&6 fi fi if test -z "$ac_cv_prog_CC"; then ac_ct_CC=$CC # Extract the first word of "gcc", so it can be a program name with args. set dummy gcc; ac_word=$2 echo "$as_me:$LINENO: checking for $ac_word" >&5 echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 if test "${ac_cv_prog_ac_ct_CC+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else if test -n "$ac_ct_CC"; then ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_ac_ct_CC="gcc" echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done fi fi ac_ct_CC=$ac_cv_prog_ac_ct_CC if test -n "$ac_ct_CC"; then echo "$as_me:$LINENO: result: $ac_ct_CC" >&5 echo "${ECHO_T}$ac_ct_CC" >&6 else echo "$as_me:$LINENO: result: no" >&5 echo "${ECHO_T}no" >&6 fi CC=$ac_ct_CC else CC="$ac_cv_prog_CC" fi if test -z "$CC"; then if test -n "$ac_tool_prefix"; then # Extract the first word of "${ac_tool_prefix}cc", so it can be a program name with args. set dummy ${ac_tool_prefix}cc; ac_word=$2 echo "$as_me:$LINENO: checking for $ac_word" >&5 echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 if test "${ac_cv_prog_CC+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_CC="${ac_tool_prefix}cc" echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done fi fi CC=$ac_cv_prog_CC if test -n "$CC"; then echo "$as_me:$LINENO: result: $CC" >&5 echo "${ECHO_T}$CC" >&6 else echo "$as_me:$LINENO: result: no" >&5 echo "${ECHO_T}no" >&6 fi fi if test -z "$ac_cv_prog_CC"; then ac_ct_CC=$CC # Extract the first word of "cc", so it can be a program name with args. set dummy cc; ac_word=$2 echo "$as_me:$LINENO: checking for $ac_word" >&5 echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 if test "${ac_cv_prog_ac_ct_CC+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else if test -n "$ac_ct_CC"; then ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_ac_ct_CC="cc" echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done fi fi ac_ct_CC=$ac_cv_prog_ac_ct_CC if test -n "$ac_ct_CC"; then echo "$as_me:$LINENO: result: $ac_ct_CC" >&5 echo "${ECHO_T}$ac_ct_CC" >&6 else echo "$as_me:$LINENO: result: no" >&5 echo "${ECHO_T}no" >&6 fi CC=$ac_ct_CC else CC="$ac_cv_prog_CC" fi fi if test -z "$CC"; then # Extract the first word of "cc", so it can be a program name with args. set dummy cc; ac_word=$2 echo "$as_me:$LINENO: checking for $ac_word" >&5 echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 if test "${ac_cv_prog_CC+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. else ac_prog_rejected=no as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then if test "$as_dir/$ac_word$ac_exec_ext" = "/usr/ucb/cc"; then ac_prog_rejected=yes continue fi ac_cv_prog_CC="cc" echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done if test $ac_prog_rejected = yes; then # We found a bogon in the path, so make sure we never use it. set dummy $ac_cv_prog_CC shift if test $# != 0; then # We chose a different compiler from the bogus one. # However, it has the same basename, so the bogon will be chosen # first if we set CC to just the basename; use the full file name. shift ac_cv_prog_CC="$as_dir/$ac_word${1+' '}$@" fi fi fi fi CC=$ac_cv_prog_CC if test -n "$CC"; then echo "$as_me:$LINENO: result: $CC" >&5 echo "${ECHO_T}$CC" >&6 else echo "$as_me:$LINENO: result: no" >&5 echo "${ECHO_T}no" >&6 fi fi if test -z "$CC"; then if test -n "$ac_tool_prefix"; then for ac_prog in cl do # Extract the first word of "$ac_tool_prefix$ac_prog", so it can be a program name with args. set dummy $ac_tool_prefix$ac_prog; ac_word=$2 echo "$as_me:$LINENO: checking for $ac_word" >&5 echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 if test "${ac_cv_prog_CC+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_CC="$ac_tool_prefix$ac_prog" echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done fi fi CC=$ac_cv_prog_CC if test -n "$CC"; then echo "$as_me:$LINENO: result: $CC" >&5 echo "${ECHO_T}$CC" >&6 else echo "$as_me:$LINENO: result: no" >&5 echo "${ECHO_T}no" >&6 fi test -n "$CC" && break done fi if test -z "$CC"; then ac_ct_CC=$CC for ac_prog in cl do # Extract the first word of "$ac_prog", so it can be a program name with args. set dummy $ac_prog; ac_word=$2 echo "$as_me:$LINENO: checking for $ac_word" >&5 echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 if test "${ac_cv_prog_ac_ct_CC+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else if test -n "$ac_ct_CC"; then ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_ac_ct_CC="$ac_prog" echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done fi fi ac_ct_CC=$ac_cv_prog_ac_ct_CC if test -n "$ac_ct_CC"; then echo "$as_me:$LINENO: result: $ac_ct_CC" >&5 echo "${ECHO_T}$ac_ct_CC" >&6 else echo "$as_me:$LINENO: result: no" >&5 echo "${ECHO_T}no" >&6 fi test -n "$ac_ct_CC" && break done CC=$ac_ct_CC fi fi test -z "$CC" && { { echo "$as_me:$LINENO: error: no acceptable C compiler found in \$PATH See \`config.log' for more details." >&5 echo "$as_me: error: no acceptable C compiler found in \$PATH See \`config.log' for more details." >&2;} { (exit 1); exit 1; }; } # Provide some information about the compiler. echo "$as_me:$LINENO:" \ "checking for C compiler version" >&5 ac_compiler=`set X $ac_compile; echo $2` { (eval echo "$as_me:$LINENO: \"$ac_compiler --version &5\"") >&5 (eval $ac_compiler --version &5) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } { (eval echo "$as_me:$LINENO: \"$ac_compiler -v &5\"") >&5 (eval $ac_compiler -v &5) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } { (eval echo "$as_me:$LINENO: \"$ac_compiler -V &5\"") >&5 (eval $ac_compiler -V &5) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int main () { ; return 0; } _ACEOF ac_clean_files_save=$ac_clean_files ac_clean_files="$ac_clean_files a.out a.exe b.out" # Try to create an executable without -o first, disregard a.out. # It will help us diagnose broken compilers, and finding out an intuition # of exeext. echo "$as_me:$LINENO: checking for C compiler default output file name" >&5 echo $ECHO_N "checking for C compiler default output file name... $ECHO_C" >&6 ac_link_default=`echo "$ac_link" | sed 's/ -o *conftest[^ ]*//'` if { (eval echo "$as_me:$LINENO: \"$ac_link_default\"") >&5 (eval $ac_link_default) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; then # Find the output, starting from the most likely. This scheme is # not robust to junk in `.', hence go to wildcards (a.*) only as a last # resort. # Be careful to initialize this variable, since it used to be cached. # Otherwise an old cache value of `no' led to `EXEEXT = no' in a Makefile. ac_cv_exeext= # b.out is created by i960 compilers. for ac_file in a_out.exe a.exe conftest.exe a.out conftest a.* conftest.* b.out do test -f "$ac_file" || continue case $ac_file in *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.o | *.obj ) ;; conftest.$ac_ext ) # This is the source file. ;; [ab].out ) # We found the default executable, but exeext='' is most # certainly right. break;; *.* ) ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'` # FIXME: I believe we export ac_cv_exeext for Libtool, # but it would be cool to find out if it's true. Does anybody # maintain Libtool? --akim. export ac_cv_exeext break;; * ) break;; esac done else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 { { echo "$as_me:$LINENO: error: C compiler cannot create executables See \`config.log' for more details." >&5 echo "$as_me: error: C compiler cannot create executables See \`config.log' for more details." >&2;} { (exit 77); exit 77; }; } fi ac_exeext=$ac_cv_exeext echo "$as_me:$LINENO: result: $ac_file" >&5 echo "${ECHO_T}$ac_file" >&6 # Check the compiler produces executables we can run. If not, either # the compiler is broken, or we cross compile. echo "$as_me:$LINENO: checking whether the C compiler works" >&5 echo $ECHO_N "checking whether the C compiler works... $ECHO_C" >&6 # FIXME: These cross compiler hacks should be removed for Autoconf 3.0 # If not cross compiling, check that we can run a simple program. if test "$cross_compiling" != yes; then if { ac_try='./$ac_file' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then cross_compiling=no else if test "$cross_compiling" = maybe; then cross_compiling=yes else { { echo "$as_me:$LINENO: error: cannot run C compiled programs. If you meant to cross compile, use \`--host'. See \`config.log' for more details." >&5 echo "$as_me: error: cannot run C compiled programs. If you meant to cross compile, use \`--host'. See \`config.log' for more details." >&2;} { (exit 1); exit 1; }; } fi fi fi echo "$as_me:$LINENO: result: yes" >&5 echo "${ECHO_T}yes" >&6 rm -f a.out a.exe conftest$ac_cv_exeext b.out ac_clean_files=$ac_clean_files_save # Check the compiler produces executables we can run. If not, either # the compiler is broken, or we cross compile. echo "$as_me:$LINENO: checking whether we are cross compiling" >&5 echo $ECHO_N "checking whether we are cross compiling... $ECHO_C" >&6 echo "$as_me:$LINENO: result: $cross_compiling" >&5 echo "${ECHO_T}$cross_compiling" >&6 echo "$as_me:$LINENO: checking for suffix of executables" >&5 echo $ECHO_N "checking for suffix of executables... $ECHO_C" >&6 if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; then # If both `conftest.exe' and `conftest' are `present' (well, observable) # catch `conftest.exe'. For instance with Cygwin, `ls conftest' will # work properly (i.e., refer to `conftest.exe'), while it won't with # `rm'. for ac_file in conftest.exe conftest conftest.*; do test -f "$ac_file" || continue case $ac_file in *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.o | *.obj ) ;; *.* ) ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'` export ac_cv_exeext break;; * ) break;; esac done else { { echo "$as_me:$LINENO: error: cannot compute suffix of executables: cannot compile and link See \`config.log' for more details." >&5 echo "$as_me: error: cannot compute suffix of executables: cannot compile and link See \`config.log' for more details." >&2;} { (exit 1); exit 1; }; } fi rm -f conftest$ac_cv_exeext echo "$as_me:$LINENO: result: $ac_cv_exeext" >&5 echo "${ECHO_T}$ac_cv_exeext" >&6 rm -f conftest.$ac_ext EXEEXT=$ac_cv_exeext ac_exeext=$EXEEXT echo "$as_me:$LINENO: checking for suffix of object files" >&5 echo $ECHO_N "checking for suffix of object files... $ECHO_C" >&6 if test "${ac_cv_objext+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int main () { ; return 0; } _ACEOF rm -f conftest.o conftest.obj if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; then for ac_file in `(ls conftest.o conftest.obj; ls conftest.*) 2>/dev/null`; do case $ac_file in *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg ) ;; *) ac_cv_objext=`expr "$ac_file" : '.*\.\(.*\)'` break;; esac done else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 { { echo "$as_me:$LINENO: error: cannot compute suffix of object files: cannot compile See \`config.log' for more details." >&5 echo "$as_me: error: cannot compute suffix of object files: cannot compile See \`config.log' for more details." >&2;} { (exit 1); exit 1; }; } fi rm -f conftest.$ac_cv_objext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_objext" >&5 echo "${ECHO_T}$ac_cv_objext" >&6 OBJEXT=$ac_cv_objext ac_objext=$OBJEXT echo "$as_me:$LINENO: checking whether we are using the GNU C compiler" >&5 echo $ECHO_N "checking whether we are using the GNU C compiler... $ECHO_C" >&6 if test "${ac_cv_c_compiler_gnu+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int main () { #ifndef __GNUC__ choke me #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_compiler_gnu=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_compiler_gnu=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext ac_cv_c_compiler_gnu=$ac_compiler_gnu fi echo "$as_me:$LINENO: result: $ac_cv_c_compiler_gnu" >&5 echo "${ECHO_T}$ac_cv_c_compiler_gnu" >&6 GCC=`test $ac_compiler_gnu = yes && echo yes` ac_test_CFLAGS=${CFLAGS+set} ac_save_CFLAGS=$CFLAGS CFLAGS="-g" echo "$as_me:$LINENO: checking whether $CC accepts -g" >&5 echo $ECHO_N "checking whether $CC accepts -g... $ECHO_C" >&6 if test "${ac_cv_prog_cc_g+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int main () { ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_prog_cc_g=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_prog_cc_g=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_prog_cc_g" >&5 echo "${ECHO_T}$ac_cv_prog_cc_g" >&6 if test "$ac_test_CFLAGS" = set; then CFLAGS=$ac_save_CFLAGS elif test $ac_cv_prog_cc_g = yes; then if test "$GCC" = yes; then CFLAGS="-g -O2" else CFLAGS="-g" fi else if test "$GCC" = yes; then CFLAGS="-O2" else CFLAGS= fi fi echo "$as_me:$LINENO: checking for $CC option to accept ANSI C" >&5 echo $ECHO_N "checking for $CC option to accept ANSI C... $ECHO_C" >&6 if test "${ac_cv_prog_cc_stdc+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_cv_prog_cc_stdc=no ac_save_CC=$CC cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include /* Most of the following tests are stolen from RCS 5.7's src/conf.sh. */ struct buf { int x; }; FILE * (*rcsopen) (struct buf *, struct stat *, int); static char *e (p, i) char **p; int i; { return p[i]; } static char *f (char * (*g) (char **, int), char **p, ...) { char *s; va_list v; va_start (v,p); s = g (p, va_arg (v,int)); va_end (v); return s; } /* OSF 4.0 Compaq cc is some sort of almost-ANSI by default. It has function prototypes and stuff, but not '\xHH' hex character constants. These don't provoke an error unfortunately, instead are silently treated as 'x'. The following induces an error, until -std1 is added to get proper ANSI mode. Curiously '\x00'!='x' always comes out true, for an array size at least. It's necessary to write '\x00'==0 to get something that's true only with -std1. */ int osf4_cc_array ['\x00' == 0 ? 1 : -1]; int test (int i, double x); struct s1 {int (*f) (int a);}; struct s2 {int (*f) (double a);}; int pairnames (int, char **, FILE *(*)(struct buf *, struct stat *, int), int, int); int argc; char **argv; int main () { return f (e, argv, 0) != argv[0] || f (e, argv, 1) != argv[1]; ; return 0; } _ACEOF # Don't try gcc -ansi; that turns off useful extensions and # breaks some systems' header files. # AIX -qlanglvl=ansi # Ultrix and OSF/1 -std1 # HP-UX 10.20 and later -Ae # HP-UX older versions -Aa -D_HPUX_SOURCE # SVR4 -Xc -D__EXTENSIONS__ for ac_arg in "" -qlanglvl=ansi -std1 -Ae "-Aa -D_HPUX_SOURCE" "-Xc -D__EXTENSIONS__" do CC="$ac_save_CC $ac_arg" rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_prog_cc_stdc=$ac_arg break else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 fi rm -f conftest.err conftest.$ac_objext done rm -f conftest.$ac_ext conftest.$ac_objext CC=$ac_save_CC fi case "x$ac_cv_prog_cc_stdc" in x|xno) echo "$as_me:$LINENO: result: none needed" >&5 echo "${ECHO_T}none needed" >&6 ;; *) echo "$as_me:$LINENO: result: $ac_cv_prog_cc_stdc" >&5 echo "${ECHO_T}$ac_cv_prog_cc_stdc" >&6 CC="$CC $ac_cv_prog_cc_stdc" ;; esac # Some people use a C++ compiler to compile C. Since we use `exit', # in C++ we need to declare it. In case someone uses the same compiler # for both compiling C and C++ we need to have the C++ compiler decide # the declaration of exit, since it's the most demanding environment. cat >conftest.$ac_ext <<_ACEOF #ifndef __cplusplus choke me #endif _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then for ac_declaration in \ '' \ 'extern "C" void std::exit (int) throw (); using std::exit;' \ 'extern "C" void std::exit (int); using std::exit;' \ 'extern "C" void exit (int) throw ();' \ 'extern "C" void exit (int);' \ 'void exit (int);' do cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_declaration #include int main () { exit (42); ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then : else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 continue fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_declaration int main () { exit (42); ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then break else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext done rm -f conftest* if test -n "$ac_declaration"; then echo '#ifdef __cplusplus' >>confdefs.h echo $ac_declaration >>confdefs.h echo '#endif' >>confdefs.h fi else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu echo "$as_me:$LINENO: checking how to run the C preprocessor" >&5 echo $ECHO_N "checking how to run the C preprocessor... $ECHO_C" >&6 # On Suns, sometimes $CPP names a directory. if test -n "$CPP" && test -d "$CPP"; then CPP= fi if test -z "$CPP"; then if test "${ac_cv_prog_CPP+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else # Double quotes because CPP needs to be expanded for CPP in "$CC -E" "$CC -E -traditional-cpp" "/lib/cpp" do ac_preproc_ok=false for ac_c_preproc_warn_flag in '' yes do # Use a header file that comes with gcc, so configuring glibc # with a fresh cross-compiler works. # Prefer to if __STDC__ is defined, since # exists even on freestanding compilers. # On the NeXT, cc -E runs the code through the compiler's parser, # not just through cpp. "Syntax error" is here to catch this case. cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #ifdef __STDC__ # include #else # include #endif Syntax error _ACEOF if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5 (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null; then if test -s conftest.err; then ac_cpp_err=$ac_c_preproc_warn_flag ac_cpp_err=$ac_cpp_err$ac_c_werror_flag else ac_cpp_err= fi else ac_cpp_err=yes fi if test -z "$ac_cpp_err"; then : else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 # Broken: fails on valid input. continue fi rm -f conftest.err conftest.$ac_ext # OK, works on sane cases. Now check whether non-existent headers # can be detected and how. cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include _ACEOF if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5 (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null; then if test -s conftest.err; then ac_cpp_err=$ac_c_preproc_warn_flag ac_cpp_err=$ac_cpp_err$ac_c_werror_flag else ac_cpp_err= fi else ac_cpp_err=yes fi if test -z "$ac_cpp_err"; then # Broken: success on invalid input. continue else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 # Passes both tests. ac_preproc_ok=: break fi rm -f conftest.err conftest.$ac_ext done # Because of `break', _AC_PREPROC_IFELSE's cleaning code was skipped. rm -f conftest.err conftest.$ac_ext if $ac_preproc_ok; then break fi done ac_cv_prog_CPP=$CPP fi CPP=$ac_cv_prog_CPP else ac_cv_prog_CPP=$CPP fi echo "$as_me:$LINENO: result: $CPP" >&5 echo "${ECHO_T}$CPP" >&6 ac_preproc_ok=false for ac_c_preproc_warn_flag in '' yes do # Use a header file that comes with gcc, so configuring glibc # with a fresh cross-compiler works. # Prefer to if __STDC__ is defined, since # exists even on freestanding compilers. # On the NeXT, cc -E runs the code through the compiler's parser, # not just through cpp. "Syntax error" is here to catch this case. cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #ifdef __STDC__ # include #else # include #endif Syntax error _ACEOF if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5 (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null; then if test -s conftest.err; then ac_cpp_err=$ac_c_preproc_warn_flag ac_cpp_err=$ac_cpp_err$ac_c_werror_flag else ac_cpp_err= fi else ac_cpp_err=yes fi if test -z "$ac_cpp_err"; then : else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 # Broken: fails on valid input. continue fi rm -f conftest.err conftest.$ac_ext # OK, works on sane cases. Now check whether non-existent headers # can be detected and how. cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include _ACEOF if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5 (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null; then if test -s conftest.err; then ac_cpp_err=$ac_c_preproc_warn_flag ac_cpp_err=$ac_cpp_err$ac_c_werror_flag else ac_cpp_err= fi else ac_cpp_err=yes fi if test -z "$ac_cpp_err"; then # Broken: success on invalid input. continue else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 # Passes both tests. ac_preproc_ok=: break fi rm -f conftest.err conftest.$ac_ext done # Because of `break', _AC_PREPROC_IFELSE's cleaning code was skipped. rm -f conftest.err conftest.$ac_ext if $ac_preproc_ok; then : else { { echo "$as_me:$LINENO: error: C preprocessor \"$CPP\" fails sanity check See \`config.log' for more details." >&5 echo "$as_me: error: C preprocessor \"$CPP\" fails sanity check See \`config.log' for more details." >&2;} { (exit 1); exit 1; }; } fi ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu # Find a good install program. We prefer a C program (faster), # so one script is as good as another. But avoid the broken or # incompatible versions: # SysV /etc/install, /usr/sbin/install # SunOS /usr/etc/install # IRIX /sbin/install # AIX /bin/install # AmigaOS /C/install, which installs bootblocks on floppy discs # AIX 4 /usr/bin/installbsd, which doesn't work without a -g flag # AFS /usr/afsws/bin/install, which mishandles nonexistent args # SVR4 /usr/ucb/install, which tries to use the nonexistent group "staff" # OS/2's system install, which has a completely different semantic # ./install, which can be erroneously created by make from ./install.sh. echo "$as_me:$LINENO: checking for a BSD-compatible install" >&5 echo $ECHO_N "checking for a BSD-compatible install... $ECHO_C" >&6 if test -z "$INSTALL"; then if test "${ac_cv_path_install+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. # Account for people who put trailing slashes in PATH elements. case $as_dir/ in ./ | .// | /cC/* | \ /etc/* | /usr/sbin/* | /usr/etc/* | /sbin/* | /usr/afsws/bin/* | \ ?:\\/os2\\/install\\/* | ?:\\/OS2\\/INSTALL\\/* | \ /usr/ucb/* ) ;; *) # OSF1 and SCO ODT 3.0 have their own names for install. # Don't use installbsd from OSF since it installs stuff as root # by default. for ac_prog in ginstall scoinst install; do for ac_exec_ext in '' $ac_executable_extensions; do if $as_executable_p "$as_dir/$ac_prog$ac_exec_ext"; then if test $ac_prog = install && grep dspmsg "$as_dir/$ac_prog$ac_exec_ext" >/dev/null 2>&1; then # AIX install. It has an incompatible calling convention. : elif test $ac_prog = install && grep pwplus "$as_dir/$ac_prog$ac_exec_ext" >/dev/null 2>&1; then # program-specific install script used by HP pwplus--don't use. : else ac_cv_path_install="$as_dir/$ac_prog$ac_exec_ext -c" break 3 fi fi done done ;; esac done fi if test "${ac_cv_path_install+set}" = set; then INSTALL=$ac_cv_path_install else # As a last resort, use the slow shell script. We don't cache a # path for INSTALL within a source directory, because that will # break other packages using the cache if that directory is # removed, or if the path is relative. INSTALL=$ac_install_sh fi fi echo "$as_me:$LINENO: result: $INSTALL" >&5 echo "${ECHO_T}$INSTALL" >&6 # Use test -z because SunOS4 sh mishandles braces in ${var-val}. # It thinks the first close brace ends the variable substitution. test -z "$INSTALL_PROGRAM" && INSTALL_PROGRAM='${INSTALL}' test -z "$INSTALL_SCRIPT" && INSTALL_SCRIPT='${INSTALL}' test -z "$INSTALL_DATA" && INSTALL_DATA='${INSTALL} -m 644' #-------------------------------------------------------------------- # Checks to see if the make program sets the $MAKE variable. #-------------------------------------------------------------------- echo "$as_me:$LINENO: checking whether ${MAKE-make} sets \$(MAKE)" >&5 echo $ECHO_N "checking whether ${MAKE-make} sets \$(MAKE)... $ECHO_C" >&6 set dummy ${MAKE-make}; ac_make=`echo "$2" | sed 'y,:./+-,___p_,'` if eval "test \"\${ac_cv_prog_make_${ac_make}_set+set}\" = set"; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.make <<\_ACEOF all: @echo 'ac_maketemp="$(MAKE)"' _ACEOF # GNU make sometimes prints "make[1]: Entering...", which would confuse us. eval `${MAKE-make} -f conftest.make 2>/dev/null | grep temp=` if test -n "$ac_maketemp"; then eval ac_cv_prog_make_${ac_make}_set=yes else eval ac_cv_prog_make_${ac_make}_set=no fi rm -f conftest.make fi if eval "test \"`echo '$ac_cv_prog_make_'${ac_make}_set`\" = yes"; then echo "$as_me:$LINENO: result: yes" >&5 echo "${ECHO_T}yes" >&6 SET_MAKE= else echo "$as_me:$LINENO: result: no" >&5 echo "${ECHO_T}no" >&6 SET_MAKE="MAKE=${MAKE-make}" fi #-------------------------------------------------------------------- # Find ranlib #-------------------------------------------------------------------- if test -n "$ac_tool_prefix"; then # Extract the first word of "${ac_tool_prefix}ranlib", so it can be a program name with args. set dummy ${ac_tool_prefix}ranlib; ac_word=$2 echo "$as_me:$LINENO: checking for $ac_word" >&5 echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 if test "${ac_cv_prog_RANLIB+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else if test -n "$RANLIB"; then ac_cv_prog_RANLIB="$RANLIB" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_RANLIB="${ac_tool_prefix}ranlib" echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done fi fi RANLIB=$ac_cv_prog_RANLIB if test -n "$RANLIB"; then echo "$as_me:$LINENO: result: $RANLIB" >&5 echo "${ECHO_T}$RANLIB" >&6 else echo "$as_me:$LINENO: result: no" >&5 echo "${ECHO_T}no" >&6 fi fi if test -z "$ac_cv_prog_RANLIB"; then ac_ct_RANLIB=$RANLIB # Extract the first word of "ranlib", so it can be a program name with args. set dummy ranlib; ac_word=$2 echo "$as_me:$LINENO: checking for $ac_word" >&5 echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 if test "${ac_cv_prog_ac_ct_RANLIB+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else if test -n "$ac_ct_RANLIB"; then ac_cv_prog_ac_ct_RANLIB="$ac_ct_RANLIB" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_ac_ct_RANLIB="ranlib" echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done test -z "$ac_cv_prog_ac_ct_RANLIB" && ac_cv_prog_ac_ct_RANLIB=":" fi fi ac_ct_RANLIB=$ac_cv_prog_ac_ct_RANLIB if test -n "$ac_ct_RANLIB"; then echo "$as_me:$LINENO: result: $ac_ct_RANLIB" >&5 echo "${ECHO_T}$ac_ct_RANLIB" >&6 else echo "$as_me:$LINENO: result: no" >&5 echo "${ECHO_T}no" >&6 fi RANLIB=$ac_ct_RANLIB else RANLIB="$ac_cv_prog_RANLIB" fi #-------------------------------------------------------------------- # Determines the correct binary file extension (.o, .obj, .exe etc.) #-------------------------------------------------------------------- echo "$as_me:$LINENO: checking for egrep" >&5 echo $ECHO_N "checking for egrep... $ECHO_C" >&6 if test "${ac_cv_prog_egrep+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else if echo a | (grep -E '(a|b)') >/dev/null 2>&1 then ac_cv_prog_egrep='grep -E' else ac_cv_prog_egrep='egrep' fi fi echo "$as_me:$LINENO: result: $ac_cv_prog_egrep" >&5 echo "${ECHO_T}$ac_cv_prog_egrep" >&6 EGREP=$ac_cv_prog_egrep echo "$as_me:$LINENO: checking for ANSI C header files" >&5 echo $ECHO_N "checking for ANSI C header files... $ECHO_C" >&6 if test "${ac_cv_header_stdc+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include int main () { ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_header_stdc=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_header_stdc=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext if test $ac_cv_header_stdc = yes; then # SunOS 4.x string.h does not declare mem*, contrary to ANSI. cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include _ACEOF if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | $EGREP "memchr" >/dev/null 2>&1; then : else ac_cv_header_stdc=no fi rm -f conftest* fi if test $ac_cv_header_stdc = yes; then # ISC 2.0.2 stdlib.h does not declare free, contrary to ANSI. cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include _ACEOF if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | $EGREP "free" >/dev/null 2>&1; then : else ac_cv_header_stdc=no fi rm -f conftest* fi if test $ac_cv_header_stdc = yes; then # /bin/cc in Irix-4.0.5 gets non-ANSI ctype macros unless using -ansi. if test "$cross_compiling" = yes; then : else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #if ((' ' & 0x0FF) == 0x020) # define ISLOWER(c) ('a' <= (c) && (c) <= 'z') # define TOUPPER(c) (ISLOWER(c) ? 'A' + ((c) - 'a') : (c)) #else # define ISLOWER(c) \ (('a' <= (c) && (c) <= 'i') \ || ('j' <= (c) && (c) <= 'r') \ || ('s' <= (c) && (c) <= 'z')) # define TOUPPER(c) (ISLOWER(c) ? ((c) | 0x40) : (c)) #endif #define XOR(e, f) (((e) && !(f)) || (!(e) && (f))) int main () { int i; for (i = 0; i < 256; i++) if (XOR (islower (i), ISLOWER (i)) || toupper (i) != TOUPPER (i)) exit(2); exit (0); } _ACEOF rm -f conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='./conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then : else echo "$as_me: program exited with status $ac_status" >&5 echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ( exit $ac_status ) ac_cv_header_stdc=no fi rm -f core *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext fi fi fi echo "$as_me:$LINENO: result: $ac_cv_header_stdc" >&5 echo "${ECHO_T}$ac_cv_header_stdc" >&6 if test $ac_cv_header_stdc = yes; then cat >>confdefs.h <<\_ACEOF #define STDC_HEADERS 1 _ACEOF fi # On IRIX 5.3, sys/types and inttypes.h are conflicting. for ac_header in sys/types.h sys/stat.h stdlib.h string.h memory.h strings.h \ inttypes.h stdint.h unistd.h do as_ac_Header=`echo "ac_cv_header_$ac_header" | $as_tr_sh` echo "$as_me:$LINENO: checking for $ac_header" >&5 echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6 if eval "test \"\${$as_ac_Header+set}\" = set"; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_includes_default #include <$ac_header> _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then eval "$as_ac_Header=yes" else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 eval "$as_ac_Header=no" fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5 echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6 if test `eval echo '${'$as_ac_Header'}'` = yes; then cat >>confdefs.h <<_ACEOF #define `echo "HAVE_$ac_header" | $as_tr_cpp` 1 _ACEOF fi done # Any macros that use the compiler (e.g. AC_TRY_COMPILE) have to go here. #------------------------------------------------------------------------ # If we're using GCC, see if the compiler understands -pipe. If so, use it. # It makes compiling go faster. (This is only a performance feature.) #------------------------------------------------------------------------ if test -z "$no_pipe" -a -n "$GCC"; then echo "$as_me:$LINENO: checking if the compiler understands -pipe" >&5 echo $ECHO_N "checking if the compiler understands -pipe... $ECHO_C" >&6 OLDCC="$CC" CC="$CC -pipe" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int main () { ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then echo "$as_me:$LINENO: result: yes" >&5 echo "${ECHO_T}yes" >&6 else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 CC="$OLDCC" echo "$as_me:$LINENO: result: no" >&5 echo "${ECHO_T}no" >&6 fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi #-------------------------------------------------------------------- # Common compiler flag setup #-------------------------------------------------------------------- echo "$as_me:$LINENO: checking whether byte ordering is bigendian" >&5 echo $ECHO_N "checking whether byte ordering is bigendian... $ECHO_C" >&6 if test "${ac_cv_c_bigendian+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else # See if sys/param.h defines the BYTE_ORDER macro. cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include int main () { #if !BYTE_ORDER || !BIG_ENDIAN || !LITTLE_ENDIAN bogus endian macros #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then # It does; now see whether it defined to BIG_ENDIAN or not. cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include int main () { #if BYTE_ORDER != BIG_ENDIAN not big endian #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_c_bigendian=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_c_bigendian=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 # It does not; compile a test program. if test "$cross_compiling" = yes; then # try to guess the endianness by grepping values into an object file ac_cv_c_bigendian=unknown cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ short ascii_mm[] = { 0x4249, 0x4765, 0x6E44, 0x6961, 0x6E53, 0x7953, 0 }; short ascii_ii[] = { 0x694C, 0x5454, 0x656C, 0x6E45, 0x6944, 0x6E61, 0 }; void _ascii () { char *s = (char *) ascii_mm; s = (char *) ascii_ii; } short ebcdic_ii[] = { 0x89D3, 0xE3E3, 0x8593, 0x95C5, 0x89C4, 0x9581, 0 }; short ebcdic_mm[] = { 0xC2C9, 0xC785, 0x95C4, 0x8981, 0x95E2, 0xA8E2, 0 }; void _ebcdic () { char *s = (char *) ebcdic_mm; s = (char *) ebcdic_ii; } int main () { _ascii (); _ebcdic (); ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then if grep BIGenDianSyS conftest.$ac_objext >/dev/null ; then ac_cv_c_bigendian=yes fi if grep LiTTleEnDian conftest.$ac_objext >/dev/null ; then if test "$ac_cv_c_bigendian" = unknown; then ac_cv_c_bigendian=no else # finding both strings is unlikely to happen, but who knows? ac_cv_c_bigendian=unknown fi fi else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int main () { /* Are we little or big endian? From Harbison&Steele. */ union { long l; char c[sizeof (long)]; } u; u.l = 1; exit (u.c[sizeof (long) - 1] == 1); } _ACEOF rm -f conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='./conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_c_bigendian=no else echo "$as_me: program exited with status $ac_status" >&5 echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ( exit $ac_status ) ac_cv_c_bigendian=yes fi rm -f core *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext fi fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_c_bigendian" >&5 echo "${ECHO_T}$ac_cv_c_bigendian" >&6 case $ac_cv_c_bigendian in yes) cat >>confdefs.h <<\_ACEOF #define WORDS_BIGENDIAN 1 _ACEOF ;; no) ;; *) { { echo "$as_me:$LINENO: error: unknown endianness presetting ac_cv_c_bigendian=no (or yes) will help" >&5 echo "$as_me: error: unknown endianness presetting ac_cv_c_bigendian=no (or yes) will help" >&2;} { (exit 1); exit 1; }; } ;; esac if test "${TEA_PLATFORM}" = "unix" ; then #-------------------------------------------------------------------- # On a few very rare systems, all of the libm.a stuff is # already in libc.a. Set compiler flags accordingly. # Also, Linux requires the "ieee" library for math to work # right (and it must appear before "-lm"). #-------------------------------------------------------------------- echo "$as_me:$LINENO: checking for sin" >&5 echo $ECHO_N "checking for sin... $ECHO_C" >&6 if test "${ac_cv_func_sin+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Define sin to an innocuous variant, in case declares sin. For example, HP-UX 11i declares gettimeofday. */ #define sin innocuous_sin /* System header to define __stub macros and hopefully few prototypes, which can conflict with char sin (); below. Prefer to if __STDC__ is defined, since exists even on freestanding compilers. */ #ifdef __STDC__ # include #else # include #endif #undef sin /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" { #endif /* We use char because int might match the return type of a gcc2 builtin and then its argument prototype would still apply. */ char sin (); /* The GNU C library defines this for functions which it implements to always fail with ENOSYS. Some functions are actually named something starting with __ and the normal name is an alias. */ #if defined (__stub_sin) || defined (__stub___sin) choke me #else char (*f) () = sin; #endif #ifdef __cplusplus } #endif int main () { return f != sin; ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_func_sin=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_func_sin=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_func_sin" >&5 echo "${ECHO_T}$ac_cv_func_sin" >&6 if test $ac_cv_func_sin = yes; then MATH_LIBS="" else MATH_LIBS="-lm" fi echo "$as_me:$LINENO: checking for main in -lieee" >&5 echo $ECHO_N "checking for main in -lieee... $ECHO_C" >&6 if test "${ac_cv_lib_ieee_main+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lieee $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int main () { main (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_lib_ieee_main=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_ieee_main=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi echo "$as_me:$LINENO: result: $ac_cv_lib_ieee_main" >&5 echo "${ECHO_T}$ac_cv_lib_ieee_main" >&6 if test $ac_cv_lib_ieee_main = yes; then MATH_LIBS="-lieee $MATH_LIBS" fi #-------------------------------------------------------------------- # Interactive UNIX requires -linet instead of -lsocket, plus it # needs net/errno.h to define the socket-related error codes. #-------------------------------------------------------------------- echo "$as_me:$LINENO: checking for main in -linet" >&5 echo $ECHO_N "checking for main in -linet... $ECHO_C" >&6 if test "${ac_cv_lib_inet_main+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-linet $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int main () { main (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_lib_inet_main=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_inet_main=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi echo "$as_me:$LINENO: result: $ac_cv_lib_inet_main" >&5 echo "${ECHO_T}$ac_cv_lib_inet_main" >&6 if test $ac_cv_lib_inet_main = yes; then LIBS="$LIBS -linet" fi if test "${ac_cv_header_net_errno_h+set}" = set; then echo "$as_me:$LINENO: checking for net/errno.h" >&5 echo $ECHO_N "checking for net/errno.h... $ECHO_C" >&6 if test "${ac_cv_header_net_errno_h+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 fi echo "$as_me:$LINENO: result: $ac_cv_header_net_errno_h" >&5 echo "${ECHO_T}$ac_cv_header_net_errno_h" >&6 else # Is the header compilable? echo "$as_me:$LINENO: checking net/errno.h usability" >&5 echo $ECHO_N "checking net/errno.h usability... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_includes_default #include _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_header_compiler=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_compiler=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 echo "${ECHO_T}$ac_header_compiler" >&6 # Is the header present? echo "$as_me:$LINENO: checking net/errno.h presence" >&5 echo $ECHO_N "checking net/errno.h presence... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include _ACEOF if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5 (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null; then if test -s conftest.err; then ac_cpp_err=$ac_c_preproc_warn_flag ac_cpp_err=$ac_cpp_err$ac_c_werror_flag else ac_cpp_err= fi else ac_cpp_err=yes fi if test -z "$ac_cpp_err"; then ac_header_preproc=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_preproc=no fi rm -f conftest.err conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 echo "${ECHO_T}$ac_header_preproc" >&6 # So? What about this header? case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in yes:no: ) { echo "$as_me:$LINENO: WARNING: net/errno.h: accepted by the compiler, rejected by the preprocessor!" >&5 echo "$as_me: WARNING: net/errno.h: accepted by the compiler, rejected by the preprocessor!" >&2;} { echo "$as_me:$LINENO: WARNING: net/errno.h: proceeding with the compiler's result" >&5 echo "$as_me: WARNING: net/errno.h: proceeding with the compiler's result" >&2;} ac_header_preproc=yes ;; no:yes:* ) { echo "$as_me:$LINENO: WARNING: net/errno.h: present but cannot be compiled" >&5 echo "$as_me: WARNING: net/errno.h: present but cannot be compiled" >&2;} { echo "$as_me:$LINENO: WARNING: net/errno.h: check for missing prerequisite headers?" >&5 echo "$as_me: WARNING: net/errno.h: check for missing prerequisite headers?" >&2;} { echo "$as_me:$LINENO: WARNING: net/errno.h: see the Autoconf documentation" >&5 echo "$as_me: WARNING: net/errno.h: see the Autoconf documentation" >&2;} { echo "$as_me:$LINENO: WARNING: net/errno.h: section \"Present But Cannot Be Compiled\"" >&5 echo "$as_me: WARNING: net/errno.h: section \"Present But Cannot Be Compiled\"" >&2;} { echo "$as_me:$LINENO: WARNING: net/errno.h: proceeding with the preprocessor's result" >&5 echo "$as_me: WARNING: net/errno.h: proceeding with the preprocessor's result" >&2;} { echo "$as_me:$LINENO: WARNING: net/errno.h: in the future, the compiler will take precedence" >&5 echo "$as_me: WARNING: net/errno.h: in the future, the compiler will take precedence" >&2;} ( cat <<\_ASBOX ## ------------------------------- ## ## Report this to the tclx lists. ## ## ------------------------------- ## _ASBOX ) | sed "s/^/$as_me: WARNING: /" >&2 ;; esac echo "$as_me:$LINENO: checking for net/errno.h" >&5 echo $ECHO_N "checking for net/errno.h... $ECHO_C" >&6 if test "${ac_cv_header_net_errno_h+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_cv_header_net_errno_h=$ac_header_preproc fi echo "$as_me:$LINENO: result: $ac_cv_header_net_errno_h" >&5 echo "${ECHO_T}$ac_cv_header_net_errno_h" >&6 fi if test $ac_cv_header_net_errno_h = yes; then cat >>confdefs.h <<\_ACEOF #define HAVE_NET_ERRNO_H 1 _ACEOF fi #-------------------------------------------------------------------- # Check for the existence of the -lsocket and -lnsl libraries. # The order here is important, so that they end up in the right # order in the command line generated by make. Here are some # special considerations: # 1. Use "connect" and "accept" to check for -lsocket, and # "gethostbyname" to check for -lnsl. # 2. Use each function name only once: can't redo a check because # autoconf caches the results of the last check and won't redo it. # 3. Use -lnsl and -lsocket only if they supply procedures that # aren't already present in the normal libraries. This is because # IRIX 5.2 has libraries, but they aren't needed and they're # bogus: they goof up name resolution if used. # 4. On some SVR4 systems, can't use -lsocket without -lnsl too. # To get around this problem, check for both libraries together # if -lsocket doesn't work by itself. #-------------------------------------------------------------------- tcl_checkBoth=0 echo "$as_me:$LINENO: checking for connect" >&5 echo $ECHO_N "checking for connect... $ECHO_C" >&6 if test "${ac_cv_func_connect+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Define connect to an innocuous variant, in case declares connect. For example, HP-UX 11i declares gettimeofday. */ #define connect innocuous_connect /* System header to define __stub macros and hopefully few prototypes, which can conflict with char connect (); below. Prefer to if __STDC__ is defined, since exists even on freestanding compilers. */ #ifdef __STDC__ # include #else # include #endif #undef connect /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" { #endif /* We use char because int might match the return type of a gcc2 builtin and then its argument prototype would still apply. */ char connect (); /* The GNU C library defines this for functions which it implements to always fail with ENOSYS. Some functions are actually named something starting with __ and the normal name is an alias. */ #if defined (__stub_connect) || defined (__stub___connect) choke me #else char (*f) () = connect; #endif #ifdef __cplusplus } #endif int main () { return f != connect; ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_func_connect=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_func_connect=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_func_connect" >&5 echo "${ECHO_T}$ac_cv_func_connect" >&6 if test $ac_cv_func_connect = yes; then tcl_checkSocket=0 else tcl_checkSocket=1 fi if test "$tcl_checkSocket" = 1; then echo "$as_me:$LINENO: checking for setsockopt" >&5 echo $ECHO_N "checking for setsockopt... $ECHO_C" >&6 if test "${ac_cv_func_setsockopt+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Define setsockopt to an innocuous variant, in case declares setsockopt. For example, HP-UX 11i declares gettimeofday. */ #define setsockopt innocuous_setsockopt /* System header to define __stub macros and hopefully few prototypes, which can conflict with char setsockopt (); below. Prefer to if __STDC__ is defined, since exists even on freestanding compilers. */ #ifdef __STDC__ # include #else # include #endif #undef setsockopt /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" { #endif /* We use char because int might match the return type of a gcc2 builtin and then its argument prototype would still apply. */ char setsockopt (); /* The GNU C library defines this for functions which it implements to always fail with ENOSYS. Some functions are actually named something starting with __ and the normal name is an alias. */ #if defined (__stub_setsockopt) || defined (__stub___setsockopt) choke me #else char (*f) () = setsockopt; #endif #ifdef __cplusplus } #endif int main () { return f != setsockopt; ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_func_setsockopt=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_func_setsockopt=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_func_setsockopt" >&5 echo "${ECHO_T}$ac_cv_func_setsockopt" >&6 if test $ac_cv_func_setsockopt = yes; then : else echo "$as_me:$LINENO: checking for setsockopt in -lsocket" >&5 echo $ECHO_N "checking for setsockopt in -lsocket... $ECHO_C" >&6 if test "${ac_cv_lib_socket_setsockopt+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lsocket $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" #endif /* We use char because int might match the return type of a gcc2 builtin and then its argument prototype would still apply. */ char setsockopt (); int main () { setsockopt (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_lib_socket_setsockopt=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_socket_setsockopt=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi echo "$as_me:$LINENO: result: $ac_cv_lib_socket_setsockopt" >&5 echo "${ECHO_T}$ac_cv_lib_socket_setsockopt" >&6 if test $ac_cv_lib_socket_setsockopt = yes; then LIBS="$LIBS -lsocket" else tcl_checkBoth=1 fi fi fi if test "$tcl_checkBoth" = 1; then tk_oldLibs=$LIBS LIBS="$LIBS -lsocket -lnsl" echo "$as_me:$LINENO: checking for accept" >&5 echo $ECHO_N "checking for accept... $ECHO_C" >&6 if test "${ac_cv_func_accept+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Define accept to an innocuous variant, in case declares accept. For example, HP-UX 11i declares gettimeofday. */ #define accept innocuous_accept /* System header to define __stub macros and hopefully few prototypes, which can conflict with char accept (); below. Prefer to if __STDC__ is defined, since exists even on freestanding compilers. */ #ifdef __STDC__ # include #else # include #endif #undef accept /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" { #endif /* We use char because int might match the return type of a gcc2 builtin and then its argument prototype would still apply. */ char accept (); /* The GNU C library defines this for functions which it implements to always fail with ENOSYS. Some functions are actually named something starting with __ and the normal name is an alias. */ #if defined (__stub_accept) || defined (__stub___accept) choke me #else char (*f) () = accept; #endif #ifdef __cplusplus } #endif int main () { return f != accept; ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_func_accept=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_func_accept=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_func_accept" >&5 echo "${ECHO_T}$ac_cv_func_accept" >&6 if test $ac_cv_func_accept = yes; then tcl_checkNsl=0 else LIBS=$tk_oldLibs fi fi echo "$as_me:$LINENO: checking for gethostbyname" >&5 echo $ECHO_N "checking for gethostbyname... $ECHO_C" >&6 if test "${ac_cv_func_gethostbyname+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Define gethostbyname to an innocuous variant, in case declares gethostbyname. For example, HP-UX 11i declares gettimeofday. */ #define gethostbyname innocuous_gethostbyname /* System header to define __stub macros and hopefully few prototypes, which can conflict with char gethostbyname (); below. Prefer to if __STDC__ is defined, since exists even on freestanding compilers. */ #ifdef __STDC__ # include #else # include #endif #undef gethostbyname /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" { #endif /* We use char because int might match the return type of a gcc2 builtin and then its argument prototype would still apply. */ char gethostbyname (); /* The GNU C library defines this for functions which it implements to always fail with ENOSYS. Some functions are actually named something starting with __ and the normal name is an alias. */ #if defined (__stub_gethostbyname) || defined (__stub___gethostbyname) choke me #else char (*f) () = gethostbyname; #endif #ifdef __cplusplus } #endif int main () { return f != gethostbyname; ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_func_gethostbyname=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_func_gethostbyname=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_func_gethostbyname" >&5 echo "${ECHO_T}$ac_cv_func_gethostbyname" >&6 if test $ac_cv_func_gethostbyname = yes; then : else echo "$as_me:$LINENO: checking for gethostbyname in -lnsl" >&5 echo $ECHO_N "checking for gethostbyname in -lnsl... $ECHO_C" >&6 if test "${ac_cv_lib_nsl_gethostbyname+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lnsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" #endif /* We use char because int might match the return type of a gcc2 builtin and then its argument prototype would still apply. */ char gethostbyname (); int main () { gethostbyname (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_lib_nsl_gethostbyname=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_nsl_gethostbyname=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi echo "$as_me:$LINENO: result: $ac_cv_lib_nsl_gethostbyname" >&5 echo "${ECHO_T}$ac_cv_lib_nsl_gethostbyname" >&6 if test $ac_cv_lib_nsl_gethostbyname = yes; then LIBS="$LIBS -lnsl" fi fi # Don't perform the eval of the libraries here because DL_LIBS # won't be set until we call TEA_CONFIG_CFLAGS TCL_LIBS='${DL_LIBS} ${LIBS} ${MATH_LIBS}' echo "$as_me:$LINENO: checking dirent.h" >&5 echo $ECHO_N "checking dirent.h... $ECHO_C" >&6 if test "${tcl_cv_dirent_h+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include int main () { #ifndef _POSIX_SOURCE # ifdef __Lynx__ /* * Generate compilation error to make the test fail: Lynx headers * are only valid if really in the POSIX environment. */ missing_procedure(); # endif #endif DIR *d; struct dirent *entryPtr; char *p; d = opendir("foobar"); entryPtr = readdir(d); p = entryPtr->d_name; closedir(d); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then tcl_cv_dirent_h=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 tcl_cv_dirent_h=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $tcl_cv_dirent_h" >&5 echo "${ECHO_T}$tcl_cv_dirent_h" >&6 if test $tcl_cv_dirent_h = no; then cat >>confdefs.h <<\_ACEOF #define NO_DIRENT_H 1 _ACEOF fi if test "${ac_cv_header_errno_h+set}" = set; then echo "$as_me:$LINENO: checking for errno.h" >&5 echo $ECHO_N "checking for errno.h... $ECHO_C" >&6 if test "${ac_cv_header_errno_h+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 fi echo "$as_me:$LINENO: result: $ac_cv_header_errno_h" >&5 echo "${ECHO_T}$ac_cv_header_errno_h" >&6 else # Is the header compilable? echo "$as_me:$LINENO: checking errno.h usability" >&5 echo $ECHO_N "checking errno.h usability... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_includes_default #include _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_header_compiler=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_compiler=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 echo "${ECHO_T}$ac_header_compiler" >&6 # Is the header present? echo "$as_me:$LINENO: checking errno.h presence" >&5 echo $ECHO_N "checking errno.h presence... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include _ACEOF if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5 (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null; then if test -s conftest.err; then ac_cpp_err=$ac_c_preproc_warn_flag ac_cpp_err=$ac_cpp_err$ac_c_werror_flag else ac_cpp_err= fi else ac_cpp_err=yes fi if test -z "$ac_cpp_err"; then ac_header_preproc=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_preproc=no fi rm -f conftest.err conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 echo "${ECHO_T}$ac_header_preproc" >&6 # So? What about this header? case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in yes:no: ) { echo "$as_me:$LINENO: WARNING: errno.h: accepted by the compiler, rejected by the preprocessor!" >&5 echo "$as_me: WARNING: errno.h: accepted by the compiler, rejected by the preprocessor!" >&2;} { echo "$as_me:$LINENO: WARNING: errno.h: proceeding with the compiler's result" >&5 echo "$as_me: WARNING: errno.h: proceeding with the compiler's result" >&2;} ac_header_preproc=yes ;; no:yes:* ) { echo "$as_me:$LINENO: WARNING: errno.h: present but cannot be compiled" >&5 echo "$as_me: WARNING: errno.h: present but cannot be compiled" >&2;} { echo "$as_me:$LINENO: WARNING: errno.h: check for missing prerequisite headers?" >&5 echo "$as_me: WARNING: errno.h: check for missing prerequisite headers?" >&2;} { echo "$as_me:$LINENO: WARNING: errno.h: see the Autoconf documentation" >&5 echo "$as_me: WARNING: errno.h: see the Autoconf documentation" >&2;} { echo "$as_me:$LINENO: WARNING: errno.h: section \"Present But Cannot Be Compiled\"" >&5 echo "$as_me: WARNING: errno.h: section \"Present But Cannot Be Compiled\"" >&2;} { echo "$as_me:$LINENO: WARNING: errno.h: proceeding with the preprocessor's result" >&5 echo "$as_me: WARNING: errno.h: proceeding with the preprocessor's result" >&2;} { echo "$as_me:$LINENO: WARNING: errno.h: in the future, the compiler will take precedence" >&5 echo "$as_me: WARNING: errno.h: in the future, the compiler will take precedence" >&2;} ( cat <<\_ASBOX ## ------------------------------- ## ## Report this to the tclx lists. ## ## ------------------------------- ## _ASBOX ) | sed "s/^/$as_me: WARNING: /" >&2 ;; esac echo "$as_me:$LINENO: checking for errno.h" >&5 echo $ECHO_N "checking for errno.h... $ECHO_C" >&6 if test "${ac_cv_header_errno_h+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_cv_header_errno_h=$ac_header_preproc fi echo "$as_me:$LINENO: result: $ac_cv_header_errno_h" >&5 echo "${ECHO_T}$ac_cv_header_errno_h" >&6 fi if test $ac_cv_header_errno_h = yes; then : else cat >>confdefs.h <<\_ACEOF #define NO_ERRNO_H 1 _ACEOF fi if test "${ac_cv_header_float_h+set}" = set; then echo "$as_me:$LINENO: checking for float.h" >&5 echo $ECHO_N "checking for float.h... $ECHO_C" >&6 if test "${ac_cv_header_float_h+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 fi echo "$as_me:$LINENO: result: $ac_cv_header_float_h" >&5 echo "${ECHO_T}$ac_cv_header_float_h" >&6 else # Is the header compilable? echo "$as_me:$LINENO: checking float.h usability" >&5 echo $ECHO_N "checking float.h usability... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_includes_default #include _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_header_compiler=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_compiler=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 echo "${ECHO_T}$ac_header_compiler" >&6 # Is the header present? echo "$as_me:$LINENO: checking float.h presence" >&5 echo $ECHO_N "checking float.h presence... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include _ACEOF if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5 (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null; then if test -s conftest.err; then ac_cpp_err=$ac_c_preproc_warn_flag ac_cpp_err=$ac_cpp_err$ac_c_werror_flag else ac_cpp_err= fi else ac_cpp_err=yes fi if test -z "$ac_cpp_err"; then ac_header_preproc=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_preproc=no fi rm -f conftest.err conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 echo "${ECHO_T}$ac_header_preproc" >&6 # So? What about this header? case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in yes:no: ) { echo "$as_me:$LINENO: WARNING: float.h: accepted by the compiler, rejected by the preprocessor!" >&5 echo "$as_me: WARNING: float.h: accepted by the compiler, rejected by the preprocessor!" >&2;} { echo "$as_me:$LINENO: WARNING: float.h: proceeding with the compiler's result" >&5 echo "$as_me: WARNING: float.h: proceeding with the compiler's result" >&2;} ac_header_preproc=yes ;; no:yes:* ) { echo "$as_me:$LINENO: WARNING: float.h: present but cannot be compiled" >&5 echo "$as_me: WARNING: float.h: present but cannot be compiled" >&2;} { echo "$as_me:$LINENO: WARNING: float.h: check for missing prerequisite headers?" >&5 echo "$as_me: WARNING: float.h: check for missing prerequisite headers?" >&2;} { echo "$as_me:$LINENO: WARNING: float.h: see the Autoconf documentation" >&5 echo "$as_me: WARNING: float.h: see the Autoconf documentation" >&2;} { echo "$as_me:$LINENO: WARNING: float.h: section \"Present But Cannot Be Compiled\"" >&5 echo "$as_me: WARNING: float.h: section \"Present But Cannot Be Compiled\"" >&2;} { echo "$as_me:$LINENO: WARNING: float.h: proceeding with the preprocessor's result" >&5 echo "$as_me: WARNING: float.h: proceeding with the preprocessor's result" >&2;} { echo "$as_me:$LINENO: WARNING: float.h: in the future, the compiler will take precedence" >&5 echo "$as_me: WARNING: float.h: in the future, the compiler will take precedence" >&2;} ( cat <<\_ASBOX ## ------------------------------- ## ## Report this to the tclx lists. ## ## ------------------------------- ## _ASBOX ) | sed "s/^/$as_me: WARNING: /" >&2 ;; esac echo "$as_me:$LINENO: checking for float.h" >&5 echo $ECHO_N "checking for float.h... $ECHO_C" >&6 if test "${ac_cv_header_float_h+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_cv_header_float_h=$ac_header_preproc fi echo "$as_me:$LINENO: result: $ac_cv_header_float_h" >&5 echo "${ECHO_T}$ac_cv_header_float_h" >&6 fi if test $ac_cv_header_float_h = yes; then : else cat >>confdefs.h <<\_ACEOF #define NO_FLOAT_H 1 _ACEOF fi if test "${ac_cv_header_values_h+set}" = set; then echo "$as_me:$LINENO: checking for values.h" >&5 echo $ECHO_N "checking for values.h... $ECHO_C" >&6 if test "${ac_cv_header_values_h+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 fi echo "$as_me:$LINENO: result: $ac_cv_header_values_h" >&5 echo "${ECHO_T}$ac_cv_header_values_h" >&6 else # Is the header compilable? echo "$as_me:$LINENO: checking values.h usability" >&5 echo $ECHO_N "checking values.h usability... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_includes_default #include _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_header_compiler=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_compiler=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 echo "${ECHO_T}$ac_header_compiler" >&6 # Is the header present? echo "$as_me:$LINENO: checking values.h presence" >&5 echo $ECHO_N "checking values.h presence... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include _ACEOF if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5 (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null; then if test -s conftest.err; then ac_cpp_err=$ac_c_preproc_warn_flag ac_cpp_err=$ac_cpp_err$ac_c_werror_flag else ac_cpp_err= fi else ac_cpp_err=yes fi if test -z "$ac_cpp_err"; then ac_header_preproc=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_preproc=no fi rm -f conftest.err conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 echo "${ECHO_T}$ac_header_preproc" >&6 # So? What about this header? case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in yes:no: ) { echo "$as_me:$LINENO: WARNING: values.h: accepted by the compiler, rejected by the preprocessor!" >&5 echo "$as_me: WARNING: values.h: accepted by the compiler, rejected by the preprocessor!" >&2;} { echo "$as_me:$LINENO: WARNING: values.h: proceeding with the compiler's result" >&5 echo "$as_me: WARNING: values.h: proceeding with the compiler's result" >&2;} ac_header_preproc=yes ;; no:yes:* ) { echo "$as_me:$LINENO: WARNING: values.h: present but cannot be compiled" >&5 echo "$as_me: WARNING: values.h: present but cannot be compiled" >&2;} { echo "$as_me:$LINENO: WARNING: values.h: check for missing prerequisite headers?" >&5 echo "$as_me: WARNING: values.h: check for missing prerequisite headers?" >&2;} { echo "$as_me:$LINENO: WARNING: values.h: see the Autoconf documentation" >&5 echo "$as_me: WARNING: values.h: see the Autoconf documentation" >&2;} { echo "$as_me:$LINENO: WARNING: values.h: section \"Present But Cannot Be Compiled\"" >&5 echo "$as_me: WARNING: values.h: section \"Present But Cannot Be Compiled\"" >&2;} { echo "$as_me:$LINENO: WARNING: values.h: proceeding with the preprocessor's result" >&5 echo "$as_me: WARNING: values.h: proceeding with the preprocessor's result" >&2;} { echo "$as_me:$LINENO: WARNING: values.h: in the future, the compiler will take precedence" >&5 echo "$as_me: WARNING: values.h: in the future, the compiler will take precedence" >&2;} ( cat <<\_ASBOX ## ------------------------------- ## ## Report this to the tclx lists. ## ## ------------------------------- ## _ASBOX ) | sed "s/^/$as_me: WARNING: /" >&2 ;; esac echo "$as_me:$LINENO: checking for values.h" >&5 echo $ECHO_N "checking for values.h... $ECHO_C" >&6 if test "${ac_cv_header_values_h+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_cv_header_values_h=$ac_header_preproc fi echo "$as_me:$LINENO: result: $ac_cv_header_values_h" >&5 echo "${ECHO_T}$ac_cv_header_values_h" >&6 fi if test $ac_cv_header_values_h = yes; then : else cat >>confdefs.h <<\_ACEOF #define NO_VALUES_H 1 _ACEOF fi if test "${ac_cv_header_limits_h+set}" = set; then echo "$as_me:$LINENO: checking for limits.h" >&5 echo $ECHO_N "checking for limits.h... $ECHO_C" >&6 if test "${ac_cv_header_limits_h+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 fi echo "$as_me:$LINENO: result: $ac_cv_header_limits_h" >&5 echo "${ECHO_T}$ac_cv_header_limits_h" >&6 else # Is the header compilable? echo "$as_me:$LINENO: checking limits.h usability" >&5 echo $ECHO_N "checking limits.h usability... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_includes_default #include _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_header_compiler=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_compiler=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 echo "${ECHO_T}$ac_header_compiler" >&6 # Is the header present? echo "$as_me:$LINENO: checking limits.h presence" >&5 echo $ECHO_N "checking limits.h presence... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include _ACEOF if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5 (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null; then if test -s conftest.err; then ac_cpp_err=$ac_c_preproc_warn_flag ac_cpp_err=$ac_cpp_err$ac_c_werror_flag else ac_cpp_err= fi else ac_cpp_err=yes fi if test -z "$ac_cpp_err"; then ac_header_preproc=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_preproc=no fi rm -f conftest.err conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 echo "${ECHO_T}$ac_header_preproc" >&6 # So? What about this header? case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in yes:no: ) { echo "$as_me:$LINENO: WARNING: limits.h: accepted by the compiler, rejected by the preprocessor!" >&5 echo "$as_me: WARNING: limits.h: accepted by the compiler, rejected by the preprocessor!" >&2;} { echo "$as_me:$LINENO: WARNING: limits.h: proceeding with the compiler's result" >&5 echo "$as_me: WARNING: limits.h: proceeding with the compiler's result" >&2;} ac_header_preproc=yes ;; no:yes:* ) { echo "$as_me:$LINENO: WARNING: limits.h: present but cannot be compiled" >&5 echo "$as_me: WARNING: limits.h: present but cannot be compiled" >&2;} { echo "$as_me:$LINENO: WARNING: limits.h: check for missing prerequisite headers?" >&5 echo "$as_me: WARNING: limits.h: check for missing prerequisite headers?" >&2;} { echo "$as_me:$LINENO: WARNING: limits.h: see the Autoconf documentation" >&5 echo "$as_me: WARNING: limits.h: see the Autoconf documentation" >&2;} { echo "$as_me:$LINENO: WARNING: limits.h: section \"Present But Cannot Be Compiled\"" >&5 echo "$as_me: WARNING: limits.h: section \"Present But Cannot Be Compiled\"" >&2;} { echo "$as_me:$LINENO: WARNING: limits.h: proceeding with the preprocessor's result" >&5 echo "$as_me: WARNING: limits.h: proceeding with the preprocessor's result" >&2;} { echo "$as_me:$LINENO: WARNING: limits.h: in the future, the compiler will take precedence" >&5 echo "$as_me: WARNING: limits.h: in the future, the compiler will take precedence" >&2;} ( cat <<\_ASBOX ## ------------------------------- ## ## Report this to the tclx lists. ## ## ------------------------------- ## _ASBOX ) | sed "s/^/$as_me: WARNING: /" >&2 ;; esac echo "$as_me:$LINENO: checking for limits.h" >&5 echo $ECHO_N "checking for limits.h... $ECHO_C" >&6 if test "${ac_cv_header_limits_h+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_cv_header_limits_h=$ac_header_preproc fi echo "$as_me:$LINENO: result: $ac_cv_header_limits_h" >&5 echo "${ECHO_T}$ac_cv_header_limits_h" >&6 fi if test $ac_cv_header_limits_h = yes; then cat >>confdefs.h <<\_ACEOF #define HAVE_LIMITS_H 1 _ACEOF else cat >>confdefs.h <<\_ACEOF #define NO_LIMITS_H 1 _ACEOF fi if test "${ac_cv_header_stdlib_h+set}" = set; then echo "$as_me:$LINENO: checking for stdlib.h" >&5 echo $ECHO_N "checking for stdlib.h... $ECHO_C" >&6 if test "${ac_cv_header_stdlib_h+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 fi echo "$as_me:$LINENO: result: $ac_cv_header_stdlib_h" >&5 echo "${ECHO_T}$ac_cv_header_stdlib_h" >&6 else # Is the header compilable? echo "$as_me:$LINENO: checking stdlib.h usability" >&5 echo $ECHO_N "checking stdlib.h usability... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_includes_default #include _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_header_compiler=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_compiler=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 echo "${ECHO_T}$ac_header_compiler" >&6 # Is the header present? echo "$as_me:$LINENO: checking stdlib.h presence" >&5 echo $ECHO_N "checking stdlib.h presence... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include _ACEOF if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5 (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null; then if test -s conftest.err; then ac_cpp_err=$ac_c_preproc_warn_flag ac_cpp_err=$ac_cpp_err$ac_c_werror_flag else ac_cpp_err= fi else ac_cpp_err=yes fi if test -z "$ac_cpp_err"; then ac_header_preproc=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_preproc=no fi rm -f conftest.err conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 echo "${ECHO_T}$ac_header_preproc" >&6 # So? What about this header? case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in yes:no: ) { echo "$as_me:$LINENO: WARNING: stdlib.h: accepted by the compiler, rejected by the preprocessor!" >&5 echo "$as_me: WARNING: stdlib.h: accepted by the compiler, rejected by the preprocessor!" >&2;} { echo "$as_me:$LINENO: WARNING: stdlib.h: proceeding with the compiler's result" >&5 echo "$as_me: WARNING: stdlib.h: proceeding with the compiler's result" >&2;} ac_header_preproc=yes ;; no:yes:* ) { echo "$as_me:$LINENO: WARNING: stdlib.h: present but cannot be compiled" >&5 echo "$as_me: WARNING: stdlib.h: present but cannot be compiled" >&2;} { echo "$as_me:$LINENO: WARNING: stdlib.h: check for missing prerequisite headers?" >&5 echo "$as_me: WARNING: stdlib.h: check for missing prerequisite headers?" >&2;} { echo "$as_me:$LINENO: WARNING: stdlib.h: see the Autoconf documentation" >&5 echo "$as_me: WARNING: stdlib.h: see the Autoconf documentation" >&2;} { echo "$as_me:$LINENO: WARNING: stdlib.h: section \"Present But Cannot Be Compiled\"" >&5 echo "$as_me: WARNING: stdlib.h: section \"Present But Cannot Be Compiled\"" >&2;} { echo "$as_me:$LINENO: WARNING: stdlib.h: proceeding with the preprocessor's result" >&5 echo "$as_me: WARNING: stdlib.h: proceeding with the preprocessor's result" >&2;} { echo "$as_me:$LINENO: WARNING: stdlib.h: in the future, the compiler will take precedence" >&5 echo "$as_me: WARNING: stdlib.h: in the future, the compiler will take precedence" >&2;} ( cat <<\_ASBOX ## ------------------------------- ## ## Report this to the tclx lists. ## ## ------------------------------- ## _ASBOX ) | sed "s/^/$as_me: WARNING: /" >&2 ;; esac echo "$as_me:$LINENO: checking for stdlib.h" >&5 echo $ECHO_N "checking for stdlib.h... $ECHO_C" >&6 if test "${ac_cv_header_stdlib_h+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_cv_header_stdlib_h=$ac_header_preproc fi echo "$as_me:$LINENO: result: $ac_cv_header_stdlib_h" >&5 echo "${ECHO_T}$ac_cv_header_stdlib_h" >&6 fi if test $ac_cv_header_stdlib_h = yes; then tcl_ok=1 else tcl_ok=0 fi cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include _ACEOF if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | $EGREP "strtol" >/dev/null 2>&1; then : else tcl_ok=0 fi rm -f conftest* cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include _ACEOF if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | $EGREP "strtoul" >/dev/null 2>&1; then : else tcl_ok=0 fi rm -f conftest* cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include _ACEOF if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | $EGREP "strtod" >/dev/null 2>&1; then : else tcl_ok=0 fi rm -f conftest* if test $tcl_ok = 0; then cat >>confdefs.h <<\_ACEOF #define NO_STDLIB_H 1 _ACEOF fi if test "${ac_cv_header_string_h+set}" = set; then echo "$as_me:$LINENO: checking for string.h" >&5 echo $ECHO_N "checking for string.h... $ECHO_C" >&6 if test "${ac_cv_header_string_h+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 fi echo "$as_me:$LINENO: result: $ac_cv_header_string_h" >&5 echo "${ECHO_T}$ac_cv_header_string_h" >&6 else # Is the header compilable? echo "$as_me:$LINENO: checking string.h usability" >&5 echo $ECHO_N "checking string.h usability... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_includes_default #include _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_header_compiler=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_compiler=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 echo "${ECHO_T}$ac_header_compiler" >&6 # Is the header present? echo "$as_me:$LINENO: checking string.h presence" >&5 echo $ECHO_N "checking string.h presence... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include _ACEOF if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5 (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null; then if test -s conftest.err; then ac_cpp_err=$ac_c_preproc_warn_flag ac_cpp_err=$ac_cpp_err$ac_c_werror_flag else ac_cpp_err= fi else ac_cpp_err=yes fi if test -z "$ac_cpp_err"; then ac_header_preproc=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_preproc=no fi rm -f conftest.err conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 echo "${ECHO_T}$ac_header_preproc" >&6 # So? What about this header? case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in yes:no: ) { echo "$as_me:$LINENO: WARNING: string.h: accepted by the compiler, rejected by the preprocessor!" >&5 echo "$as_me: WARNING: string.h: accepted by the compiler, rejected by the preprocessor!" >&2;} { echo "$as_me:$LINENO: WARNING: string.h: proceeding with the compiler's result" >&5 echo "$as_me: WARNING: string.h: proceeding with the compiler's result" >&2;} ac_header_preproc=yes ;; no:yes:* ) { echo "$as_me:$LINENO: WARNING: string.h: present but cannot be compiled" >&5 echo "$as_me: WARNING: string.h: present but cannot be compiled" >&2;} { echo "$as_me:$LINENO: WARNING: string.h: check for missing prerequisite headers?" >&5 echo "$as_me: WARNING: string.h: check for missing prerequisite headers?" >&2;} { echo "$as_me:$LINENO: WARNING: string.h: see the Autoconf documentation" >&5 echo "$as_me: WARNING: string.h: see the Autoconf documentation" >&2;} { echo "$as_me:$LINENO: WARNING: string.h: section \"Present But Cannot Be Compiled\"" >&5 echo "$as_me: WARNING: string.h: section \"Present But Cannot Be Compiled\"" >&2;} { echo "$as_me:$LINENO: WARNING: string.h: proceeding with the preprocessor's result" >&5 echo "$as_me: WARNING: string.h: proceeding with the preprocessor's result" >&2;} { echo "$as_me:$LINENO: WARNING: string.h: in the future, the compiler will take precedence" >&5 echo "$as_me: WARNING: string.h: in the future, the compiler will take precedence" >&2;} ( cat <<\_ASBOX ## ------------------------------- ## ## Report this to the tclx lists. ## ## ------------------------------- ## _ASBOX ) | sed "s/^/$as_me: WARNING: /" >&2 ;; esac echo "$as_me:$LINENO: checking for string.h" >&5 echo $ECHO_N "checking for string.h... $ECHO_C" >&6 if test "${ac_cv_header_string_h+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_cv_header_string_h=$ac_header_preproc fi echo "$as_me:$LINENO: result: $ac_cv_header_string_h" >&5 echo "${ECHO_T}$ac_cv_header_string_h" >&6 fi if test $ac_cv_header_string_h = yes; then tcl_ok=1 else tcl_ok=0 fi cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include _ACEOF if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | $EGREP "strstr" >/dev/null 2>&1; then : else tcl_ok=0 fi rm -f conftest* cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include _ACEOF if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | $EGREP "strerror" >/dev/null 2>&1; then : else tcl_ok=0 fi rm -f conftest* # See also memmove check below for a place where NO_STRING_H can be # set and why. if test $tcl_ok = 0; then cat >>confdefs.h <<\_ACEOF #define NO_STRING_H 1 _ACEOF fi if test "${ac_cv_header_sys_wait_h+set}" = set; then echo "$as_me:$LINENO: checking for sys/wait.h" >&5 echo $ECHO_N "checking for sys/wait.h... $ECHO_C" >&6 if test "${ac_cv_header_sys_wait_h+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 fi echo "$as_me:$LINENO: result: $ac_cv_header_sys_wait_h" >&5 echo "${ECHO_T}$ac_cv_header_sys_wait_h" >&6 else # Is the header compilable? echo "$as_me:$LINENO: checking sys/wait.h usability" >&5 echo $ECHO_N "checking sys/wait.h usability... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_includes_default #include _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_header_compiler=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_compiler=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 echo "${ECHO_T}$ac_header_compiler" >&6 # Is the header present? echo "$as_me:$LINENO: checking sys/wait.h presence" >&5 echo $ECHO_N "checking sys/wait.h presence... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include _ACEOF if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5 (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null; then if test -s conftest.err; then ac_cpp_err=$ac_c_preproc_warn_flag ac_cpp_err=$ac_cpp_err$ac_c_werror_flag else ac_cpp_err= fi else ac_cpp_err=yes fi if test -z "$ac_cpp_err"; then ac_header_preproc=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_preproc=no fi rm -f conftest.err conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 echo "${ECHO_T}$ac_header_preproc" >&6 # So? What about this header? case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in yes:no: ) { echo "$as_me:$LINENO: WARNING: sys/wait.h: accepted by the compiler, rejected by the preprocessor!" >&5 echo "$as_me: WARNING: sys/wait.h: accepted by the compiler, rejected by the preprocessor!" >&2;} { echo "$as_me:$LINENO: WARNING: sys/wait.h: proceeding with the compiler's result" >&5 echo "$as_me: WARNING: sys/wait.h: proceeding with the compiler's result" >&2;} ac_header_preproc=yes ;; no:yes:* ) { echo "$as_me:$LINENO: WARNING: sys/wait.h: present but cannot be compiled" >&5 echo "$as_me: WARNING: sys/wait.h: present but cannot be compiled" >&2;} { echo "$as_me:$LINENO: WARNING: sys/wait.h: check for missing prerequisite headers?" >&5 echo "$as_me: WARNING: sys/wait.h: check for missing prerequisite headers?" >&2;} { echo "$as_me:$LINENO: WARNING: sys/wait.h: see the Autoconf documentation" >&5 echo "$as_me: WARNING: sys/wait.h: see the Autoconf documentation" >&2;} { echo "$as_me:$LINENO: WARNING: sys/wait.h: section \"Present But Cannot Be Compiled\"" >&5 echo "$as_me: WARNING: sys/wait.h: section \"Present But Cannot Be Compiled\"" >&2;} { echo "$as_me:$LINENO: WARNING: sys/wait.h: proceeding with the preprocessor's result" >&5 echo "$as_me: WARNING: sys/wait.h: proceeding with the preprocessor's result" >&2;} { echo "$as_me:$LINENO: WARNING: sys/wait.h: in the future, the compiler will take precedence" >&5 echo "$as_me: WARNING: sys/wait.h: in the future, the compiler will take precedence" >&2;} ( cat <<\_ASBOX ## ------------------------------- ## ## Report this to the tclx lists. ## ## ------------------------------- ## _ASBOX ) | sed "s/^/$as_me: WARNING: /" >&2 ;; esac echo "$as_me:$LINENO: checking for sys/wait.h" >&5 echo $ECHO_N "checking for sys/wait.h... $ECHO_C" >&6 if test "${ac_cv_header_sys_wait_h+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_cv_header_sys_wait_h=$ac_header_preproc fi echo "$as_me:$LINENO: result: $ac_cv_header_sys_wait_h" >&5 echo "${ECHO_T}$ac_cv_header_sys_wait_h" >&6 fi if test $ac_cv_header_sys_wait_h = yes; then : else cat >>confdefs.h <<\_ACEOF #define NO_SYS_WAIT_H 1 _ACEOF fi if test "${ac_cv_header_dlfcn_h+set}" = set; then echo "$as_me:$LINENO: checking for dlfcn.h" >&5 echo $ECHO_N "checking for dlfcn.h... $ECHO_C" >&6 if test "${ac_cv_header_dlfcn_h+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 fi echo "$as_me:$LINENO: result: $ac_cv_header_dlfcn_h" >&5 echo "${ECHO_T}$ac_cv_header_dlfcn_h" >&6 else # Is the header compilable? echo "$as_me:$LINENO: checking dlfcn.h usability" >&5 echo $ECHO_N "checking dlfcn.h usability... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_includes_default #include _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_header_compiler=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_compiler=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 echo "${ECHO_T}$ac_header_compiler" >&6 # Is the header present? echo "$as_me:$LINENO: checking dlfcn.h presence" >&5 echo $ECHO_N "checking dlfcn.h presence... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include _ACEOF if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5 (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null; then if test -s conftest.err; then ac_cpp_err=$ac_c_preproc_warn_flag ac_cpp_err=$ac_cpp_err$ac_c_werror_flag else ac_cpp_err= fi else ac_cpp_err=yes fi if test -z "$ac_cpp_err"; then ac_header_preproc=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_preproc=no fi rm -f conftest.err conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 echo "${ECHO_T}$ac_header_preproc" >&6 # So? What about this header? case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in yes:no: ) { echo "$as_me:$LINENO: WARNING: dlfcn.h: accepted by the compiler, rejected by the preprocessor!" >&5 echo "$as_me: WARNING: dlfcn.h: accepted by the compiler, rejected by the preprocessor!" >&2;} { echo "$as_me:$LINENO: WARNING: dlfcn.h: proceeding with the compiler's result" >&5 echo "$as_me: WARNING: dlfcn.h: proceeding with the compiler's result" >&2;} ac_header_preproc=yes ;; no:yes:* ) { echo "$as_me:$LINENO: WARNING: dlfcn.h: present but cannot be compiled" >&5 echo "$as_me: WARNING: dlfcn.h: present but cannot be compiled" >&2;} { echo "$as_me:$LINENO: WARNING: dlfcn.h: check for missing prerequisite headers?" >&5 echo "$as_me: WARNING: dlfcn.h: check for missing prerequisite headers?" >&2;} { echo "$as_me:$LINENO: WARNING: dlfcn.h: see the Autoconf documentation" >&5 echo "$as_me: WARNING: dlfcn.h: see the Autoconf documentation" >&2;} { echo "$as_me:$LINENO: WARNING: dlfcn.h: section \"Present But Cannot Be Compiled\"" >&5 echo "$as_me: WARNING: dlfcn.h: section \"Present But Cannot Be Compiled\"" >&2;} { echo "$as_me:$LINENO: WARNING: dlfcn.h: proceeding with the preprocessor's result" >&5 echo "$as_me: WARNING: dlfcn.h: proceeding with the preprocessor's result" >&2;} { echo "$as_me:$LINENO: WARNING: dlfcn.h: in the future, the compiler will take precedence" >&5 echo "$as_me: WARNING: dlfcn.h: in the future, the compiler will take precedence" >&2;} ( cat <<\_ASBOX ## ------------------------------- ## ## Report this to the tclx lists. ## ## ------------------------------- ## _ASBOX ) | sed "s/^/$as_me: WARNING: /" >&2 ;; esac echo "$as_me:$LINENO: checking for dlfcn.h" >&5 echo $ECHO_N "checking for dlfcn.h... $ECHO_C" >&6 if test "${ac_cv_header_dlfcn_h+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_cv_header_dlfcn_h=$ac_header_preproc fi echo "$as_me:$LINENO: result: $ac_cv_header_dlfcn_h" >&5 echo "${ECHO_T}$ac_cv_header_dlfcn_h" >&6 fi if test $ac_cv_header_dlfcn_h = yes; then : else cat >>confdefs.h <<\_ACEOF #define NO_DLFCN_H 1 _ACEOF fi # OS/390 lacks sys/param.h (and doesn't need it, by chance). for ac_header in sys/param.h do as_ac_Header=`echo "ac_cv_header_$ac_header" | $as_tr_sh` if eval "test \"\${$as_ac_Header+set}\" = set"; then echo "$as_me:$LINENO: checking for $ac_header" >&5 echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6 if eval "test \"\${$as_ac_Header+set}\" = set"; then echo $ECHO_N "(cached) $ECHO_C" >&6 fi echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5 echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6 else # Is the header compilable? echo "$as_me:$LINENO: checking $ac_header usability" >&5 echo $ECHO_N "checking $ac_header usability... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_includes_default #include <$ac_header> _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_header_compiler=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_compiler=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 echo "${ECHO_T}$ac_header_compiler" >&6 # Is the header present? echo "$as_me:$LINENO: checking $ac_header presence" >&5 echo $ECHO_N "checking $ac_header presence... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include <$ac_header> _ACEOF if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5 (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null; then if test -s conftest.err; then ac_cpp_err=$ac_c_preproc_warn_flag ac_cpp_err=$ac_cpp_err$ac_c_werror_flag else ac_cpp_err= fi else ac_cpp_err=yes fi if test -z "$ac_cpp_err"; then ac_header_preproc=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_preproc=no fi rm -f conftest.err conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 echo "${ECHO_T}$ac_header_preproc" >&6 # So? What about this header? case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in yes:no: ) { echo "$as_me:$LINENO: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&5 echo "$as_me: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&2;} { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the compiler's result" >&5 echo "$as_me: WARNING: $ac_header: proceeding with the compiler's result" >&2;} ac_header_preproc=yes ;; no:yes:* ) { echo "$as_me:$LINENO: WARNING: $ac_header: present but cannot be compiled" >&5 echo "$as_me: WARNING: $ac_header: present but cannot be compiled" >&2;} { echo "$as_me:$LINENO: WARNING: $ac_header: check for missing prerequisite headers?" >&5 echo "$as_me: WARNING: $ac_header: check for missing prerequisite headers?" >&2;} { echo "$as_me:$LINENO: WARNING: $ac_header: see the Autoconf documentation" >&5 echo "$as_me: WARNING: $ac_header: see the Autoconf documentation" >&2;} { echo "$as_me:$LINENO: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&5 echo "$as_me: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&2;} { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the preprocessor's result" >&5 echo "$as_me: WARNING: $ac_header: proceeding with the preprocessor's result" >&2;} { echo "$as_me:$LINENO: WARNING: $ac_header: in the future, the compiler will take precedence" >&5 echo "$as_me: WARNING: $ac_header: in the future, the compiler will take precedence" >&2;} ( cat <<\_ASBOX ## ------------------------------- ## ## Report this to the tclx lists. ## ## ------------------------------- ## _ASBOX ) | sed "s/^/$as_me: WARNING: /" >&2 ;; esac echo "$as_me:$LINENO: checking for $ac_header" >&5 echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6 if eval "test \"\${$as_ac_Header+set}\" = set"; then echo $ECHO_N "(cached) $ECHO_C" >&6 else eval "$as_ac_Header=\$ac_header_preproc" fi echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5 echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6 fi if test `eval echo '${'$as_ac_Header'}'` = yes; then cat >>confdefs.h <<_ACEOF #define `echo "HAVE_$ac_header" | $as_tr_cpp` 1 _ACEOF fi done # Let the user call this, because if it triggers, they will # need a compat/strtod.c that is correct. Users can also # use Tcl_GetDouble(FromObj) instead. #TEA_BUGGY_STRTOD fi vars=" tclXbsearch.c tclXchmod.c tclXcmdloop.c tclXdebug.c tclXdup.c tclXfcntl.c tclXfilecmds.c tclXfilescan.c tclXflock.c tclXfstat.c tclXgeneral.c tclXhandles.c tclXinit.c tclXkeylist.c tclXlib.c tclXlist.c tclXmath.c tclXmsgcat.c tclXprocess.c tclXprofile.c tclXselect.c tclXsignal.c tclXstring.c tclXsocket.c tclXutil.c tclXoscmds.c tclXlgets.c " for i in $vars; do case $i in \$*) # allow $-var names PKG_SOURCES="$PKG_SOURCES $i" PKG_OBJECTS="$PKG_OBJECTS $i" ;; *) # check for existence - allows for generic/win/unix VPATH if test ! -f "${srcdir}/$i" -a ! -f "${srcdir}/generic/$i" \ -a ! -f "${srcdir}/win/$i" -a ! -f "${srcdir}/unix/$i" \ ; then { { echo "$as_me:$LINENO: error: could not find source file '$i'" >&5 echo "$as_me: error: could not find source file '$i'" >&2;} { (exit 1); exit 1; }; } fi PKG_SOURCES="$PKG_SOURCES $i" # this assumes it is in a VPATH dir i=`basename $i` # handle user calling this before or after TEA_SETUP_COMPILER if test x"${OBJEXT}" != x ; then j="`echo $i | sed -e 's/\.[^.]*$//'`.${OBJEXT}" else j="`echo $i | sed -e 's/\.[^.]*$//'`.\${OBJEXT}" fi PKG_OBJECTS="$PKG_OBJECTS $j" ;; esac done vars="generic/tclExtend.h" for i in $vars; do # check for existence, be strict because it is installed if test ! -f "${srcdir}/$i" ; then { { echo "$as_me:$LINENO: error: could not find header file '${srcdir}/$i'" >&5 echo "$as_me: error: could not find header file '${srcdir}/$i'" >&2;} { (exit 1); exit 1; }; } fi PKG_HEADERS="$PKG_HEADERS $i" done vars="-I\"`${CYGPATH} ${srcdir}/generic`\"" for i in $vars; do PKG_INCLUDES="$PKG_INCLUDES $i" done vars="" for i in $vars; do if test "${TEA_PLATFORM}" = "windows" -a "$GCC" = "yes" ; then # Convert foo.lib to -lfoo for GCC. No-op if not *.lib i=`echo "$i" | sed -e 's/^\([^-].*\)\.lib$/-l\1/i'` fi PKG_LIBS="$PKG_LIBS $i" done PKG_CFLAGS="$PKG_CFLAGS " vars="" for i in $vars; do # check for existence - allows for generic/win/unix VPATH if test ! -f "${srcdir}/$i" -a ! -f "${srcdir}/generic/$i" \ -a ! -f "${srcdir}/win/$i" -a ! -f "${srcdir}/unix/$i" \ ; then { { echo "$as_me:$LINENO: error: could not find stub source file '$i'" >&5 echo "$as_me: error: could not find stub source file '$i'" >&2;} { (exit 1); exit 1; }; } fi PKG_STUB_SOURCES="$PKG_STUB_SOURCES $i" # this assumes it is in a VPATH dir i=`basename $i` # handle user calling this before or after TEA_SETUP_COMPILER if test x"${OBJEXT}" != x ; then j="`echo $i | sed -e 's/\.[^.]*$//'`.${OBJEXT}" else j="`echo $i | sed -e 's/\.[^.]*$//'`.\${OBJEXT}" fi PKG_STUB_OBJECTS="$PKG_STUB_OBJECTS $j" done vars=" library/tclx.tcl library/autoload.tcl library/arrayprocs.tcl library/compat.tcl library/convlib.tcl library/edprocs.tcl library/events.tcl library/forfile.tcl library/globrecur.tcl library/help.tcl library/profrep.tcl library/pushd.tcl library/setfuncs.tcl library/showproc.tcl library/stringfile.tcl library/tcllib.tcl library/fmath.tcl library/buildhelp.tcl " for i in $vars; do # check for existence, be strict because it is installed if test ! -f "${srcdir}/$i" ; then { { echo "$as_me:$LINENO: error: could not find tcl source file '${srcdir}/$i'" >&5 echo "$as_me: error: could not find tcl source file '${srcdir}/$i'" >&2;} { (exit 1); exit 1; }; } fi PKG_TCL_SOURCES="$PKG_TCL_SOURCES $i" done #-------------------------------------------------------------------- # Choose which headers you need. Extension authors should try very # hard to only rely on the Tcl public header files. Internal headers # contain private data structures and are subject to change without # notice. # This MUST be called after TEA_LOAD_TCLCONFIG / TEA_LOAD_TKCONFIG #-------------------------------------------------------------------- #TEA_PUBLIC_TCL_HEADERS echo "$as_me:$LINENO: checking for Tcl private include files" >&5 echo $ECHO_N "checking for Tcl private include files... $ECHO_C" >&6 TCL_SRC_DIR_NATIVE=`${CYGPATH} ${TCL_SRC_DIR}` TCL_TOP_DIR_NATIVE=\"${TCL_SRC_DIR_NATIVE}\" TCL_GENERIC_DIR_NATIVE=\"${TCL_SRC_DIR_NATIVE}/generic\" TCL_UNIX_DIR_NATIVE=\"${TCL_SRC_DIR_NATIVE}/unix\" TCL_WIN_DIR_NATIVE=\"${TCL_SRC_DIR_NATIVE}/win\" TCL_BMAP_DIR_NATIVE=\"${TCL_SRC_DIR_NATIVE}/bitmaps\" TCL_TOOL_DIR_NATIVE=\"${TCL_SRC_DIR_NATIVE}/tools\" TCL_COMPAT_DIR_NATIVE=\"${TCL_SRC_DIR_NATIVE}/compat\" if test "${TEA_PLATFORM}" = "windows"; then TCL_PLATFORM_DIR_NATIVE=${TCL_WIN_DIR_NATIVE} else TCL_PLATFORM_DIR_NATIVE=${TCL_UNIX_DIR_NATIVE} fi # We want to ensure these are substituted so as not to require # any *_NATIVE vars be defined in the Makefile TCL_INCLUDES="-I${TCL_GENERIC_DIR_NATIVE} -I${TCL_PLATFORM_DIR_NATIVE}" if test "`uname -s`" = "Darwin"; then # If Tcl was built as a framework, attempt to use # the framework's Headers and PrivateHeaders directories case ${TCL_DEFS} in *TCL_FRAMEWORK*) if test -d "${TCL_BIN_DIR}/Headers" -a -d "${TCL_BIN_DIR}/PrivateHeaders"; then TCL_INCLUDES="-I\"${TCL_BIN_DIR}/Headers\" -I\"${TCL_BIN_DIR}/PrivateHeaders\" ${TCL_INCLUDES}"; else TCL_INCLUDES="${TCL_INCLUDES} ${TCL_INCLUDE_SPEC} `echo "${TCL_INCLUDE_SPEC}" | sed -e 's/Headers/PrivateHeaders/'`"; fi ;; esac fi echo "$as_me:$LINENO: result: Using srcdir found in tclConfig.sh: ${TCL_SRC_DIR}" >&5 echo "${ECHO_T}Using srcdir found in tclConfig.sh: ${TCL_SRC_DIR}" >&6 #-------------------------------------------------------------------- # __CHANGE__ # A few miscellaneous platform-specific items: # # Define a special symbol for Windows (BUILD_tclx in this case) so # that we create the export library with the dll. See sha1.h on how # to use this. # # Windows creates a few extra files that need to be cleaned up. # You can add more files to clean if your extension creates any extra # files. # # Define any extra compiler flags in the PACKAGE_CFLAGS variable. # These will be appended to the current set of compiler flags for # your system. #-------------------------------------------------------------------- if test "${TEA_PLATFORM}" = "windows" ; then cat >>confdefs.h <<\_ACEOF #define BUILD_tclx 1 _ACEOF CLEANFILES="pkgIndex.tcl *.lib *.dll *.exp *.ilk *.pdb vc*.pch" vars="tclXwinCmds.c tclXwinDup.c tclXwinId.c tclXwinOS.c" for i in $vars; do case $i in \$*) # allow $-var names PKG_SOURCES="$PKG_SOURCES $i" PKG_OBJECTS="$PKG_OBJECTS $i" ;; *) # check for existence - allows for generic/win/unix VPATH if test ! -f "${srcdir}/$i" -a ! -f "${srcdir}/generic/$i" \ -a ! -f "${srcdir}/win/$i" -a ! -f "${srcdir}/unix/$i" \ ; then { { echo "$as_me:$LINENO: error: could not find source file '$i'" >&5 echo "$as_me: error: could not find source file '$i'" >&2;} { (exit 1); exit 1; }; } fi PKG_SOURCES="$PKG_SOURCES $i" # this assumes it is in a VPATH dir i=`basename $i` # handle user calling this before or after TEA_SETUP_COMPILER if test x"${OBJEXT}" != x ; then j="`echo $i | sed -e 's/\.[^.]*$//'`.${OBJEXT}" else j="`echo $i | sed -e 's/\.[^.]*$//'`.\${OBJEXT}" fi PKG_OBJECTS="$PKG_OBJECTS $j" ;; esac done vars="wsock32.lib" for i in $vars; do if test "${TEA_PLATFORM}" = "windows" -a "$GCC" = "yes" ; then # Convert foo.lib to -lfoo for GCC. No-op if not *.lib i=`echo "$i" | sed -e 's/^\([^-].*\)\.lib$/-l\1/i'` fi PKG_LIBS="$PKG_LIBS $i" done vars="-I\"`${CYGPATH} ${srcdir}/win`\"" for i in $vars; do PKG_INCLUDES="$PKG_INCLUDES $i" done else CLEANFILES="pkgIndex.tcl" vars="tclXunixCmds.c tclXunixDup.c tclXunixId.c tclXunixOS.c tclXunixSock.c" for i in $vars; do case $i in \$*) # allow $-var names PKG_SOURCES="$PKG_SOURCES $i" PKG_OBJECTS="$PKG_OBJECTS $i" ;; *) # check for existence - allows for generic/win/unix VPATH if test ! -f "${srcdir}/$i" -a ! -f "${srcdir}/generic/$i" \ -a ! -f "${srcdir}/win/$i" -a ! -f "${srcdir}/unix/$i" \ ; then { { echo "$as_me:$LINENO: error: could not find source file '$i'" >&5 echo "$as_me: error: could not find source file '$i'" >&2;} { (exit 1); exit 1; }; } fi PKG_SOURCES="$PKG_SOURCES $i" # this assumes it is in a VPATH dir i=`basename $i` # handle user calling this before or after TEA_SETUP_COMPILER if test x"${OBJEXT}" != x ; then j="`echo $i | sed -e 's/\.[^.]*$//'`.${OBJEXT}" else j="`echo $i | sed -e 's/\.[^.]*$//'`.\${OBJEXT}" fi PKG_OBJECTS="$PKG_OBJECTS $j" ;; esac done vars="${MATH_LIBS}" for i in $vars; do if test "${TEA_PLATFORM}" = "windows" -a "$GCC" = "yes" ; then # Convert foo.lib to -lfoo for GCC. No-op if not *.lib i=`echo "$i" | sed -e 's/^\([^-].*\)\.lib$/-l\1/i'` fi PKG_LIBS="$PKG_LIBS $i" done vars="-I\"${srcdir}/unix\"" for i in $vars; do PKG_INCLUDES="$PKG_INCLUDES $i" done fi #-------------------------------------------------------------------- # Check whether --enable-threads or --disable-threads was given. #-------------------------------------------------------------------- # Check whether --enable-threads or --disable-threads was given. if test "${enable_threads+set}" = set; then enableval="$enable_threads" tcl_ok=$enableval else tcl_ok=yes fi; if test "${enable_threads+set}" = set; then enableval="$enable_threads" tcl_ok=$enableval else tcl_ok=yes fi if test "$tcl_ok" = "yes" -o "${TCL_THREADS}" = 1; then TCL_THREADS=1 if test "${TEA_PLATFORM}" != "windows" ; then # We are always OK on Windows, so check what this platform wants: # USE_THREAD_ALLOC tells us to try the special thread-based # allocator that significantly reduces lock contention cat >>confdefs.h <<\_ACEOF #define USE_THREAD_ALLOC 1 _ACEOF cat >>confdefs.h <<\_ACEOF #define _REENTRANT 1 _ACEOF if test "`uname -s`" = "SunOS" ; then cat >>confdefs.h <<\_ACEOF #define _POSIX_PTHREAD_SEMANTICS 1 _ACEOF fi cat >>confdefs.h <<\_ACEOF #define _THREAD_SAFE 1 _ACEOF echo "$as_me:$LINENO: checking for pthread_mutex_init in -lpthread" >&5 echo $ECHO_N "checking for pthread_mutex_init in -lpthread... $ECHO_C" >&6 if test "${ac_cv_lib_pthread_pthread_mutex_init+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lpthread $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" #endif /* We use char because int might match the return type of a gcc2 builtin and then its argument prototype would still apply. */ char pthread_mutex_init (); int main () { pthread_mutex_init (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_lib_pthread_pthread_mutex_init=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_pthread_pthread_mutex_init=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi echo "$as_me:$LINENO: result: $ac_cv_lib_pthread_pthread_mutex_init" >&5 echo "${ECHO_T}$ac_cv_lib_pthread_pthread_mutex_init" >&6 if test $ac_cv_lib_pthread_pthread_mutex_init = yes; then tcl_ok=yes else tcl_ok=no fi if test "$tcl_ok" = "no"; then # Check a little harder for __pthread_mutex_init in the same # library, as some systems hide it there until pthread.h is # defined. We could alternatively do an AC_TRY_COMPILE with # pthread.h, but that will work with libpthread really doesn't # exist, like AIX 4.2. [Bug: 4359] echo "$as_me:$LINENO: checking for __pthread_mutex_init in -lpthread" >&5 echo $ECHO_N "checking for __pthread_mutex_init in -lpthread... $ECHO_C" >&6 if test "${ac_cv_lib_pthread___pthread_mutex_init+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lpthread $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" #endif /* We use char because int might match the return type of a gcc2 builtin and then its argument prototype would still apply. */ char __pthread_mutex_init (); int main () { __pthread_mutex_init (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_lib_pthread___pthread_mutex_init=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_pthread___pthread_mutex_init=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi echo "$as_me:$LINENO: result: $ac_cv_lib_pthread___pthread_mutex_init" >&5 echo "${ECHO_T}$ac_cv_lib_pthread___pthread_mutex_init" >&6 if test $ac_cv_lib_pthread___pthread_mutex_init = yes; then tcl_ok=yes else tcl_ok=no fi fi if test "$tcl_ok" = "yes"; then # The space is needed THREADS_LIBS=" -lpthread" else echo "$as_me:$LINENO: checking for pthread_mutex_init in -lpthreads" >&5 echo $ECHO_N "checking for pthread_mutex_init in -lpthreads... $ECHO_C" >&6 if test "${ac_cv_lib_pthreads_pthread_mutex_init+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lpthreads $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" #endif /* We use char because int might match the return type of a gcc2 builtin and then its argument prototype would still apply. */ char pthread_mutex_init (); int main () { pthread_mutex_init (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_lib_pthreads_pthread_mutex_init=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_pthreads_pthread_mutex_init=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi echo "$as_me:$LINENO: result: $ac_cv_lib_pthreads_pthread_mutex_init" >&5 echo "${ECHO_T}$ac_cv_lib_pthreads_pthread_mutex_init" >&6 if test $ac_cv_lib_pthreads_pthread_mutex_init = yes; then tcl_ok=yes else tcl_ok=no fi if test "$tcl_ok" = "yes"; then # The space is needed THREADS_LIBS=" -lpthreads" else echo "$as_me:$LINENO: checking for pthread_mutex_init in -lc" >&5 echo $ECHO_N "checking for pthread_mutex_init in -lc... $ECHO_C" >&6 if test "${ac_cv_lib_c_pthread_mutex_init+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lc $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" #endif /* We use char because int might match the return type of a gcc2 builtin and then its argument prototype would still apply. */ char pthread_mutex_init (); int main () { pthread_mutex_init (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_lib_c_pthread_mutex_init=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_c_pthread_mutex_init=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi echo "$as_me:$LINENO: result: $ac_cv_lib_c_pthread_mutex_init" >&5 echo "${ECHO_T}$ac_cv_lib_c_pthread_mutex_init" >&6 if test $ac_cv_lib_c_pthread_mutex_init = yes; then tcl_ok=yes else tcl_ok=no fi if test "$tcl_ok" = "no"; then echo "$as_me:$LINENO: checking for pthread_mutex_init in -lc_r" >&5 echo $ECHO_N "checking for pthread_mutex_init in -lc_r... $ECHO_C" >&6 if test "${ac_cv_lib_c_r_pthread_mutex_init+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lc_r $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" #endif /* We use char because int might match the return type of a gcc2 builtin and then its argument prototype would still apply. */ char pthread_mutex_init (); int main () { pthread_mutex_init (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_lib_c_r_pthread_mutex_init=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_c_r_pthread_mutex_init=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi echo "$as_me:$LINENO: result: $ac_cv_lib_c_r_pthread_mutex_init" >&5 echo "${ECHO_T}$ac_cv_lib_c_r_pthread_mutex_init" >&6 if test $ac_cv_lib_c_r_pthread_mutex_init = yes; then tcl_ok=yes else tcl_ok=no fi if test "$tcl_ok" = "yes"; then # The space is needed THREADS_LIBS=" -pthread" else TCL_THREADS=0 { echo "$as_me:$LINENO: WARNING: Do not know how to find pthread lib on your system - thread support disabled" >&5 echo "$as_me: WARNING: Do not know how to find pthread lib on your system - thread support disabled" >&2;} fi fi fi fi fi else TCL_THREADS=0 fi # Do checking message here to not mess up interleaved configure output echo "$as_me:$LINENO: checking for building with threads" >&5 echo $ECHO_N "checking for building with threads... $ECHO_C" >&6 if test "${TCL_THREADS}" = 1; then cat >>confdefs.h <<\_ACEOF #define TCL_THREADS 1 _ACEOF echo "$as_me:$LINENO: result: yes (default)" >&5 echo "${ECHO_T}yes (default)" >&6 else echo "$as_me:$LINENO: result: no" >&5 echo "${ECHO_T}no" >&6 fi # TCL_THREADS sanity checking. See if our request for building with # threads is the same as the way Tcl was built. If not, warn the user. case ${TCL_DEFS} in *THREADS=1*) if test "${TCL_THREADS}" = "0"; then { echo "$as_me:$LINENO: WARNING: Building ${PACKAGE_NAME} without threads enabled, but building against Tcl that IS thread-enabled. It is recommended to use --enable-threads." >&5 echo "$as_me: WARNING: Building ${PACKAGE_NAME} without threads enabled, but building against Tcl that IS thread-enabled. It is recommended to use --enable-threads." >&2;} fi ;; *) if test "${TCL_THREADS}" = "1"; then { echo "$as_me:$LINENO: WARNING: --enable-threads requested, but building against a Tcl that is NOT thread-enabled. This is an OK configuration that will also run in a thread-enabled core." >&5 echo "$as_me: WARNING: --enable-threads requested, but building against a Tcl that is NOT thread-enabled. This is an OK configuration that will also run in a thread-enabled core." >&2;} fi ;; esac #-------------------------------------------------------------------- # The statement below defines a collection of symbols related to # building as a shared library instead of a static library. #-------------------------------------------------------------------- echo "$as_me:$LINENO: checking how to build libraries" >&5 echo $ECHO_N "checking how to build libraries... $ECHO_C" >&6 # Check whether --enable-shared or --disable-shared was given. if test "${enable_shared+set}" = set; then enableval="$enable_shared" tcl_ok=$enableval else tcl_ok=yes fi; if test "${enable_shared+set}" = set; then enableval="$enable_shared" tcl_ok=$enableval else tcl_ok=yes fi if test "$tcl_ok" = "yes" ; then echo "$as_me:$LINENO: result: shared" >&5 echo "${ECHO_T}shared" >&6 SHARED_BUILD=1 else echo "$as_me:$LINENO: result: static" >&5 echo "${ECHO_T}static" >&6 SHARED_BUILD=0 cat >>confdefs.h <<\_ACEOF #define STATIC_BUILD 1 _ACEOF fi #-------------------------------------------------------------------- # This macro figures out what flags to use with the compiler/linker # when building shared/static debug/optimized objects. This information # can be taken from the tclConfig.sh file, but this figures it all out. #-------------------------------------------------------------------- # Step 0.a: Enable 64 bit support? echo "$as_me:$LINENO: checking if 64bit support is requested" >&5 echo $ECHO_N "checking if 64bit support is requested... $ECHO_C" >&6 # Check whether --enable-64bit or --disable-64bit was given. if test "${enable_64bit+set}" = set; then enableval="$enable_64bit" do64bit=$enableval else do64bit=no fi; echo "$as_me:$LINENO: result: $do64bit" >&5 echo "${ECHO_T}$do64bit" >&6 # Step 0.b: Enable Solaris 64 bit VIS support? echo "$as_me:$LINENO: checking if 64bit Sparc VIS support is requested" >&5 echo $ECHO_N "checking if 64bit Sparc VIS support is requested... $ECHO_C" >&6 # Check whether --enable-64bit-vis or --disable-64bit-vis was given. if test "${enable_64bit_vis+set}" = set; then enableval="$enable_64bit_vis" do64bitVIS=$enableval else do64bitVIS=no fi; echo "$as_me:$LINENO: result: $do64bitVIS" >&5 echo "${ECHO_T}$do64bitVIS" >&6 if test "$do64bitVIS" = "yes"; then # Force 64bit on with VIS do64bit=yes fi # Step 0.c: Cross-compiling options for Windows/CE builds? if test "${TEA_PLATFORM}" = "windows" ; then echo "$as_me:$LINENO: checking if Windows/CE build is requested" >&5 echo $ECHO_N "checking if Windows/CE build is requested... $ECHO_C" >&6 # Check whether --enable-wince or --disable-wince was given. if test "${enable_wince+set}" = set; then enableval="$enable_wince" doWince=$enableval else doWince=no fi; echo "$as_me:$LINENO: result: $doWince" >&5 echo "${ECHO_T}$doWince" >&6 fi # Step 1: set the variable "system" to hold the name and version number # for the system. echo "$as_me:$LINENO: checking system version" >&5 echo $ECHO_N "checking system version... $ECHO_C" >&6 if test "${tcl_cv_sys_version+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else if test "${TEA_PLATFORM}" = "windows" ; then tcl_cv_sys_version=windows elif test -f /usr/lib/NextStep/software_version; then tcl_cv_sys_version=NEXTSTEP-`awk '/3/,/3/' /usr/lib/NextStep/software_version` else tcl_cv_sys_version=`uname -s`-`uname -r` if test "$?" -ne 0 ; then { echo "$as_me:$LINENO: WARNING: can't find uname command" >&5 echo "$as_me: WARNING: can't find uname command" >&2;} tcl_cv_sys_version=unknown else # Special check for weird MP-RAS system (uname returns weird # results, and the version is kept in special file). if test -r /etc/.relid -a "X`uname -n`" = "X`uname -s`" ; then tcl_cv_sys_version=MP-RAS-`awk '{print }' /etc/.relid` fi if test "`uname -s`" = "AIX" ; then tcl_cv_sys_version=AIX-`uname -v`.`uname -r` fi fi fi fi echo "$as_me:$LINENO: result: $tcl_cv_sys_version" >&5 echo "${ECHO_T}$tcl_cv_sys_version" >&6 system=$tcl_cv_sys_version # Step 2: check for existence of -ldl library. This is needed because # Linux can use either -ldl or -ldld for dynamic loading. echo "$as_me:$LINENO: checking for dlopen in -ldl" >&5 echo $ECHO_N "checking for dlopen in -ldl... $ECHO_C" >&6 if test "${ac_cv_lib_dl_dlopen+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-ldl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" #endif /* We use char because int might match the return type of a gcc2 builtin and then its argument prototype would still apply. */ char dlopen (); int main () { dlopen (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_lib_dl_dlopen=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_dl_dlopen=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi echo "$as_me:$LINENO: result: $ac_cv_lib_dl_dlopen" >&5 echo "${ECHO_T}$ac_cv_lib_dl_dlopen" >&6 if test $ac_cv_lib_dl_dlopen = yes; then have_dl=yes else have_dl=no fi # Require ranlib early so we can override it in special cases below. # Step 3: set configuration options based on system name and version. # This is similar to Tcl's unix/tcl.m4 except that we've added a # "windows" case. do64bit_ok=no LDFLAGS_ORIG="$LDFLAGS" # When ld needs options to work in 64-bit mode, put them in # LDFLAGS_ARCH so they eventually end up in LDFLAGS even if [load] # is disabled by the user. [Bug 1016796] LDFLAGS_ARCH="" TCL_EXPORT_FILE_SUFFIX="" UNSHARED_LIB_SUFFIX="" TCL_TRIM_DOTS='`echo ${PACKAGE_VERSION} | tr -d .`' ECHO_VERSION='`echo ${PACKAGE_VERSION}`' TCL_LIB_VERSIONS_OK=ok CFLAGS_DEBUG=-g CFLAGS_OPTIMIZE=-O if test "$GCC" = "yes" ; then CFLAGS_OPTIMIZE=-O2 CFLAGS_WARNING="-Wall -Wno-implicit-int" else CFLAGS_WARNING="" fi TCL_NEEDS_EXP_FILE=0 TCL_BUILD_EXP_FILE="" TCL_EXP_FILE="" # Extract the first word of "ar", so it can be a program name with args. set dummy ar; ac_word=$2 echo "$as_me:$LINENO: checking for $ac_word" >&5 echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 if test "${ac_cv_prog_AR+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else if test -n "$AR"; then ac_cv_prog_AR="$AR" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_AR="ar" echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done fi fi AR=$ac_cv_prog_AR if test -n "$AR"; then echo "$as_me:$LINENO: result: $AR" >&5 echo "${ECHO_T}$AR" >&6 else echo "$as_me:$LINENO: result: no" >&5 echo "${ECHO_T}no" >&6 fi STLIB_LD='${AR} cr' LD_LIBRARY_PATH_VAR="LD_LIBRARY_PATH" case $system in windows) # This is a 2-stage check to make sure we have the 64-bit SDK # We have to know where the SDK is installed. # This magic is based on MS Platform SDK for Win2003 SP1 - hobbs # MACHINE is IX86 for LINK, but this is used by the manifest, # which requires x86|amd64|ia64. MACHINE="X86" if test "$do64bit" != "no" ; then if test "x${MSSDK}x" = "xx" ; then MSSDK="C:/Progra~1/Microsoft Platform SDK" fi MSSDK=`echo "$MSSDK" | sed -e 's!\\\!/!g'` PATH64="" case "$do64bit" in amd64|x64|yes) MACHINE="AMD64" ; # default to AMD64 64-bit build PATH64="${MSSDK}/Bin/Win64/x86/AMD64" ;; ia64) MACHINE="IA64" PATH64="${MSSDK}/Bin/Win64" ;; esac if test ! -d "${PATH64}" ; then { echo "$as_me:$LINENO: WARNING: Could not find 64-bit $MACHINE SDK to enable 64bit mode" >&5 echo "$as_me: WARNING: Could not find 64-bit $MACHINE SDK to enable 64bit mode" >&2;} { echo "$as_me:$LINENO: WARNING: Ensure latest Platform SDK is installed" >&5 echo "$as_me: WARNING: Ensure latest Platform SDK is installed" >&2;} do64bit="no" else echo "$as_me:$LINENO: result: Using 64-bit $MACHINE mode" >&5 echo "${ECHO_T} Using 64-bit $MACHINE mode" >&6 do64bit_ok="yes" fi fi if test "$doWince" != "no" ; then if test "$do64bit" != "no" ; then { { echo "$as_me:$LINENO: error: Windows/CE and 64-bit builds incompatible" >&5 echo "$as_me: error: Windows/CE and 64-bit builds incompatible" >&2;} { (exit 1); exit 1; }; } fi if test "$GCC" = "yes" ; then { { echo "$as_me:$LINENO: error: Windows/CE and GCC builds incompatible" >&5 echo "$as_me: error: Windows/CE and GCC builds incompatible" >&2;} { (exit 1); exit 1; }; } fi # First, look for one uninstalled. # the alternative search directory is invoked by --with-celib if test x"${no_celib}" = x ; then # we reset no_celib in case something fails here no_celib=true # Check whether --with-celib or --without-celib was given. if test "${with_celib+set}" = set; then withval="$with_celib" with_celibconfig=${withval} fi; echo "$as_me:$LINENO: checking for Windows/CE celib directory" >&5 echo $ECHO_N "checking for Windows/CE celib directory... $ECHO_C" >&6 if test "${ac_cv_c_celibconfig+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else # First check to see if --with-celibconfig was specified. if test x"${with_celibconfig}" != x ; then if test -d "${with_celibconfig}/inc" ; then ac_cv_c_celibconfig=`(cd ${with_celibconfig}; pwd)` else { { echo "$as_me:$LINENO: error: ${with_celibconfig} directory doesn't contain inc directory" >&5 echo "$as_me: error: ${with_celibconfig} directory doesn't contain inc directory" >&2;} { (exit 1); exit 1; }; } fi fi # then check for a celib library if test x"${ac_cv_c_celibconfig}" = x ; then for i in \ ../celib-palm-3.0 \ ../celib \ ../../celib-palm-3.0 \ ../../celib \ `ls -dr ../celib-*3.[0-9]* 2>/dev/null` \ ${srcdir}/../celib-palm-3.0 \ ${srcdir}/../celib \ `ls -dr ${srcdir}/../celib-*3.[0-9]* 2>/dev/null` \ ; do if test -d "$i/inc" ; then ac_cv_c_celibconfig=`(cd $i; pwd)` break fi done fi fi if test x"${ac_cv_c_celibconfig}" = x ; then { { echo "$as_me:$LINENO: error: Cannot find celib support library directory" >&5 echo "$as_me: error: Cannot find celib support library directory" >&2;} { (exit 1); exit 1; }; } else no_celib= CELIB_DIR=${ac_cv_c_celibconfig} CELIB_DIR=`echo "$CELIB_DIR" | sed -e 's!\\\!/!g'` echo "$as_me:$LINENO: result: found $CELIB_DIR" >&5 echo "${ECHO_T}found $CELIB_DIR" >&6 fi fi # Set defaults for common evc4/PPC2003 setup # Currently Tcl requires 300+, possibly 420+ for sockets CEVERSION=420; # could be 211 300 301 400 420 ... TARGETCPU=ARMV4; # could be ARMV4 ARM MIPS SH3 X86 ... ARCH=ARM; # could be ARM MIPS X86EM ... PLATFORM="Pocket PC 2003"; # or "Pocket PC 2002" if test "$doWince" != "yes"; then # If !yes then the user specified something # Reset ARCH to allow user to skip specifying it ARCH= eval `echo $doWince | awk -F, '{ \ if (length($1)) { printf "CEVERSION=\"%s\"\n", $1; \ if ($1 < 400) { printf "PLATFORM=\"Pocket PC 2002\"\n" } }; \ if (length($2)) { printf "TARGETCPU=\"%s\"\n", toupper($2) }; \ if (length($3)) { printf "ARCH=\"%s\"\n", toupper($3) }; \ if (length($4)) { printf "PLATFORM=\"%s\"\n", $4 }; \ }'` if test "x${ARCH}" = "x" ; then ARCH=$TARGETCPU; fi fi OSVERSION=WCE$CEVERSION; if test "x${WCEROOT}" = "x" ; then WCEROOT="C:/Program Files/Microsoft eMbedded C++ 4.0" if test ! -d "${WCEROOT}" ; then WCEROOT="C:/Program Files/Microsoft eMbedded Tools" fi fi if test "x${SDKROOT}" = "x" ; then SDKROOT="C:/Program Files/Windows CE Tools" if test ! -d "${SDKROOT}" ; then SDKROOT="C:/Windows CE Tools" fi fi WCEROOT=`echo "$WCEROOT" | sed -e 's!\\\!/!g'` SDKROOT=`echo "$SDKROOT" | sed -e 's!\\\!/!g'` if test ! -d "${SDKROOT}/${OSVERSION}/${PLATFORM}/Lib/${TARGETCPU}" \ -o ! -d "${WCEROOT}/EVC/${OSVERSION}/bin"; then { { echo "$as_me:$LINENO: error: could not find PocketPC SDK or target compiler to enable WinCE mode $CEVERSION,$TARGETCPU,$ARCH,$PLATFORM" >&5 echo "$as_me: error: could not find PocketPC SDK or target compiler to enable WinCE mode $CEVERSION,$TARGETCPU,$ARCH,$PLATFORM" >&2;} { (exit 1); exit 1; }; } doWince="no" else # We could PATH_NOSPACE these, but that's not important, # as long as we quote them when used. CEINCLUDE="${SDKROOT}/${OSVERSION}/${PLATFORM}/include" if test -d "${CEINCLUDE}/${TARGETCPU}" ; then CEINCLUDE="${CEINCLUDE}/${TARGETCPU}" fi CELIBPATH="${SDKROOT}/${OSVERSION}/${PLATFORM}/Lib/${TARGETCPU}" fi fi if test "$GCC" != "yes" ; then if test "${SHARED_BUILD}" = "0" ; then runtime=-MT else runtime=-MD fi if test "$do64bit" != "no" ; then # All this magic is necessary for the Win64 SDK RC1 - hobbs CC="\"${PATH64}/cl.exe\"" CFLAGS="${CFLAGS} -I\"${MSSDK}/Include\" -I\"${MSSDK}/Include/crt\" -I\"${MSSDK}/Include/crt/sys\"" RC="\"${MSSDK}/bin/rc.exe\"" lflags="-nologo -MACHINE:${MACHINE} -LIBPATH:\"${MSSDK}/Lib/${MACHINE}\"" LINKBIN="\"${PATH64}/link.exe\"" CFLAGS_DEBUG="-nologo -Zi -Od -W3 ${runtime}d" CFLAGS_OPTIMIZE="-nologo -O2 -W2 ${runtime}" # Avoid 'unresolved external symbol __security_cookie' # errors, c.f. http://support.microsoft.com/?id=894573 vars="bufferoverflowU.lib" for i in $vars; do if test "${TEA_PLATFORM}" = "windows" -a "$GCC" = "yes" ; then # Convert foo.lib to -lfoo for GCC. No-op if not *.lib i=`echo "$i" | sed -e 's/^\([^-].*\)\.lib$/-l\1/i'` fi PKG_LIBS="$PKG_LIBS $i" done elif test "$doWince" != "no" ; then CEBINROOT="${WCEROOT}/EVC/${OSVERSION}/bin" if test "${TARGETCPU}" = "X86"; then CC="\"${CEBINROOT}/cl.exe\"" else CC="\"${CEBINROOT}/cl${ARCH}.exe\"" fi CFLAGS="$CFLAGS -I\"${CELIB_DIR}/inc\" -I\"${CEINCLUDE}\"" RC="\"${WCEROOT}/Common/EVC/bin/rc.exe\"" arch=`echo ${ARCH} | awk '{print tolower($0)}'` defs="${ARCH} _${ARCH}_ ${arch} PALM_SIZE _MT _WINDOWS" if test "${SHARED_BUILD}" = "1" ; then # Static CE builds require static celib as well defs="${defs} _DLL" fi for i in $defs ; do cat >>confdefs.h <<_ACEOF #define $i 1 _ACEOF done cat >>confdefs.h <<_ACEOF #define _WIN32_WCE $CEVERSION _ACEOF cat >>confdefs.h <<_ACEOF #define UNDER_CE $CEVERSION _ACEOF CFLAGS_DEBUG="-nologo -Zi -Od" CFLAGS_OPTIMIZE="-nologo -Ox" lversion=`echo ${CEVERSION} | sed -e 's/\(.\)\(..\)/\1\.\2/'` lflags="-MACHINE:${ARCH} -LIBPATH:\"${CELIBPATH}\" -subsystem:windowsce,${lversion} -nologo" LINKBIN="\"${CEBINROOT}/link.exe\"" else RC="rc" lflags="-nologo" LINKBIN="link" CFLAGS_DEBUG="-nologo -Z7 -Od -W3 -WX ${runtime}d" CFLAGS_OPTIMIZE="-nologo -O2 -W2 ${runtime}" fi fi if test "$GCC" = "yes"; then # mingw gcc mode RC="windres" CFLAGS_DEBUG="-g" CFLAGS_OPTIMIZE="-O2 -fomit-frame-pointer" SHLIB_LD="$CC -shared" UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.a' LDFLAGS_CONSOLE="-wl,--subsystem,console ${lflags}" LDFLAGS_WINDOW="-wl,--subsystem,windows ${lflags}" else SHLIB_LD="${LINKBIN} -dll ${lflags}" # link -lib only works when -lib is the first arg STLIB_LD="${LINKBIN} -lib ${lflags}" UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.lib' PATHTYPE=-w # For information on what debugtype is most useful, see: # http://msdn.microsoft.com/library/en-us/dnvc60/html/gendepdebug.asp # This essentially turns it all on. LDFLAGS_DEBUG="-debug:full -debugtype:both -warn:2" LDFLAGS_OPTIMIZE="-release" if test "$doWince" != "no" ; then LDFLAGS_CONSOLE="-link ${lflags}" LDFLAGS_WINDOW=${LDFLAGS_CONSOLE} else LDFLAGS_CONSOLE="-link -subsystem:console ${lflags}" LDFLAGS_WINDOW="-link -subsystem:windows ${lflags}" fi fi SHLIB_LD_LIBS='${LIBS}' SHLIB_SUFFIX=".dll" SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.dll' TCL_LIB_VERSIONS_OK=nodots # Bogus to avoid getting this turned off DL_OBJS="tclLoadNone.obj" ;; AIX-*) if test "${TCL_THREADS}" = "1" -a "$GCC" != "yes" ; then # AIX requires the _r compiler when gcc isn't being used case "${CC}" in *_r) # ok ... ;; *) CC=${CC}_r ;; esac echo "$as_me:$LINENO: result: Using $CC for compiling with threads" >&5 echo "${ECHO_T}Using $CC for compiling with threads" >&6 fi LIBS="$LIBS -lc" SHLIB_CFLAGS="" SHLIB_LD_LIBS='${LIBS}' SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" LD_LIBRARY_PATH_VAR="LIBPATH" # Check to enable 64-bit flags for compiler/linker on AIX 4+ if test "$do64bit" = "yes" -a "`uname -v`" -gt "3" ; then if test "$GCC" = "yes" ; then { echo "$as_me:$LINENO: WARNING: 64bit mode not supported with GCC on $system" >&5 echo "$as_me: WARNING: 64bit mode not supported with GCC on $system" >&2;} else do64bit_ok=yes CFLAGS="$CFLAGS -q64" LDFLAGS_ARCH="-q64" RANLIB="${RANLIB} -X64" AR="${AR} -X64" SHLIB_LD_FLAGS="-b64" fi fi if test "`uname -m`" = "ia64" ; then # AIX-5 uses ELF style dynamic libraries on IA-64, but not PPC SHLIB_LD="/usr/ccs/bin/ld -G -z text" # AIX-5 has dl* in libc.so DL_LIBS="" if test "$GCC" = "yes" ; then CC_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}' else CC_SEARCH_FLAGS='-R${LIB_RUNTIME_DIR}' fi LD_SEARCH_FLAGS='-R ${LIB_RUNTIME_DIR}' else if test "$GCC" = "yes" ; then SHLIB_LD="gcc -shared" else SHLIB_LD="/bin/ld -bhalt:4 -bM:SRE -bE:lib.exp -H512 -T512 -bnoentry" fi SHLIB_LD="${TCL_SRC_DIR}/unix/ldAix ${SHLIB_LD} ${SHLIB_LD_FLAGS}" DL_LIBS="-ldl" CC_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}' LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} TCL_NEEDS_EXP_FILE=1 TCL_EXPORT_FILE_SUFFIX='${PACKAGE_VERSION}.exp' fi # AIX v<=4.1 has some different flags than 4.2+ if test "$system" = "AIX-4.1" -o "`uname -v`" -lt "4" ; then case $LIBOBJS in "tclLoadAix.$ac_objext" | \ *" tclLoadAix.$ac_objext" | \ "tclLoadAix.$ac_objext "* | \ *" tclLoadAix.$ac_objext "* ) ;; *) LIBOBJS="$LIBOBJS tclLoadAix.$ac_objext" ;; esac DL_LIBS="-lld" fi # On AIX <=v4 systems, libbsd.a has to be linked in to support # non-blocking file IO. This library has to be linked in after # the MATH_LIBS or it breaks the pow() function. The way to # insure proper sequencing, is to add it to the tail of MATH_LIBS. # This library also supplies gettimeofday. # # AIX does not have a timezone field in struct tm. When the AIX # bsd library is used, the timezone global and the gettimeofday # methods are to be avoided for timezone deduction instead, we # deduce the timezone by comparing the localtime result on a # known GMT value. echo "$as_me:$LINENO: checking for gettimeofday in -lbsd" >&5 echo $ECHO_N "checking for gettimeofday in -lbsd... $ECHO_C" >&6 if test "${ac_cv_lib_bsd_gettimeofday+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lbsd $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" #endif /* We use char because int might match the return type of a gcc2 builtin and then its argument prototype would still apply. */ char gettimeofday (); int main () { gettimeofday (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_lib_bsd_gettimeofday=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_bsd_gettimeofday=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi echo "$as_me:$LINENO: result: $ac_cv_lib_bsd_gettimeofday" >&5 echo "${ECHO_T}$ac_cv_lib_bsd_gettimeofday" >&6 if test $ac_cv_lib_bsd_gettimeofday = yes; then libbsd=yes else libbsd=no fi if test $libbsd = yes; then MATH_LIBS="$MATH_LIBS -lbsd" cat >>confdefs.h <<\_ACEOF #define USE_DELTA_FOR_TZ 1 _ACEOF fi ;; BeOS*) SHLIB_CFLAGS="-fPIC" SHLIB_LD="${CC} -nostart" SHLIB_LD_LIBS='${LIBS}' SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="-ldl" #----------------------------------------------------------- # Check for inet_ntoa in -lbind, for BeOS (which also needs # -lsocket, even if the network functions are in -lnet which # is always linked to, for compatibility. #----------------------------------------------------------- echo "$as_me:$LINENO: checking for inet_ntoa in -lbind" >&5 echo $ECHO_N "checking for inet_ntoa in -lbind... $ECHO_C" >&6 if test "${ac_cv_lib_bind_inet_ntoa+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lbind $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" #endif /* We use char because int might match the return type of a gcc2 builtin and then its argument prototype would still apply. */ char inet_ntoa (); int main () { inet_ntoa (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_lib_bind_inet_ntoa=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_bind_inet_ntoa=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi echo "$as_me:$LINENO: result: $ac_cv_lib_bind_inet_ntoa" >&5 echo "${ECHO_T}$ac_cv_lib_bind_inet_ntoa" >&6 if test $ac_cv_lib_bind_inet_ntoa = yes; then LIBS="$LIBS -lbind -lsocket" fi ;; BSD/OS-2.1*|BSD/OS-3*) SHLIB_CFLAGS="" SHLIB_LD="shlicc -r" SHLIB_LD_LIBS='${LIBS}' SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="-ldl" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; BSD/OS-4.*) SHLIB_CFLAGS="-export-dynamic -fPIC" SHLIB_LD="cc -shared" SHLIB_LD_LIBS='${LIBS}' SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="-ldl" LDFLAGS="$LDFLAGS -export-dynamic" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; dgux*) SHLIB_CFLAGS="-K PIC" SHLIB_LD="cc -G" SHLIB_LD_LIBS="" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="-ldl" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; HP-UX-*.11.*) # Use updated header definitions where possible cat >>confdefs.h <<\_ACEOF #define _XOPEN_SOURCE_EXTENDED 1 _ACEOF # Needed by Tcl, but not most extensions #AC_DEFINE(_XOPEN_SOURCE, 1, [Do we want to use the XOPEN network library?]) #LIBS="$LIBS -lxnet" # Use the XOPEN network library SHLIB_SUFFIX=".sl" echo "$as_me:$LINENO: checking for shl_load in -ldld" >&5 echo $ECHO_N "checking for shl_load in -ldld... $ECHO_C" >&6 if test "${ac_cv_lib_dld_shl_load+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-ldld $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" #endif /* We use char because int might match the return type of a gcc2 builtin and then its argument prototype would still apply. */ char shl_load (); int main () { shl_load (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_lib_dld_shl_load=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_dld_shl_load=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi echo "$as_me:$LINENO: result: $ac_cv_lib_dld_shl_load" >&5 echo "${ECHO_T}$ac_cv_lib_dld_shl_load" >&6 if test $ac_cv_lib_dld_shl_load = yes; then tcl_ok=yes else tcl_ok=no fi if test "$tcl_ok" = yes; then SHLIB_CFLAGS="+z" SHLIB_LD="ld -b" SHLIB_LD_LIBS='${LIBS}' DL_OBJS="tclLoadShl.o" DL_LIBS="-ldld" LDFLAGS="$LDFLAGS -Wl,-E" CC_SEARCH_FLAGS='-Wl,+s,+b,${LIB_RUNTIME_DIR}:.' LD_SEARCH_FLAGS='+s +b ${LIB_RUNTIME_DIR}:.' LD_LIBRARY_PATH_VAR="SHLIB_PATH" fi if test "$GCC" = "yes" ; then SHLIB_LD="gcc -shared" SHLIB_LD_LIBS='${LIBS}' LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} fi # Users may want PA-RISC 1.1/2.0 portable code - needs HP cc #CFLAGS="$CFLAGS +DAportable" # Check to enable 64-bit flags for compiler/linker if test "$do64bit" = "yes" ; then if test "$GCC" = "yes" ; then hpux_arch=`${CC} -dumpmachine` case $hpux_arch in hppa64*) # 64-bit gcc in use. Fix flags for GNU ld. do64bit_ok=yes SHLIB_LD="${CC} -shared" SHLIB_LD_LIBS='${LIBS}' CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} ;; *) { echo "$as_me:$LINENO: WARNING: 64bit mode not supported with GCC on $system" >&5 echo "$as_me: WARNING: 64bit mode not supported with GCC on $system" >&2;} ;; esac else do64bit_ok=yes CFLAGS="$CFLAGS +DD64" LDFLAGS_ARCH="+DD64" fi fi ;; HP-UX-*.08.*|HP-UX-*.09.*|HP-UX-*.10.*) SHLIB_SUFFIX=".sl" echo "$as_me:$LINENO: checking for shl_load in -ldld" >&5 echo $ECHO_N "checking for shl_load in -ldld... $ECHO_C" >&6 if test "${ac_cv_lib_dld_shl_load+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-ldld $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" #endif /* We use char because int might match the return type of a gcc2 builtin and then its argument prototype would still apply. */ char shl_load (); int main () { shl_load (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_lib_dld_shl_load=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_dld_shl_load=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi echo "$as_me:$LINENO: result: $ac_cv_lib_dld_shl_load" >&5 echo "${ECHO_T}$ac_cv_lib_dld_shl_load" >&6 if test $ac_cv_lib_dld_shl_load = yes; then tcl_ok=yes else tcl_ok=no fi if test "$tcl_ok" = yes; then SHLIB_CFLAGS="+z" SHLIB_LD="ld -b" SHLIB_LD_LIBS="" DL_OBJS="tclLoadShl.o" DL_LIBS="-ldld" LDFLAGS="$LDFLAGS -Wl,-E" CC_SEARCH_FLAGS='-Wl,+s,+b,${LIB_RUNTIME_DIR}:.' LD_SEARCH_FLAGS='+s +b ${LIB_RUNTIME_DIR}:.' LD_LIBRARY_PATH_VAR="SHLIB_PATH" fi ;; IRIX-5.*) SHLIB_CFLAGS="" SHLIB_LD="ld -shared -rdata_shared" SHLIB_LD_LIBS='${LIBS}' SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}' ;; IRIX-6.*) SHLIB_CFLAGS="" SHLIB_LD="ld -n32 -shared -rdata_shared" SHLIB_LD_LIBS='${LIBS}' SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}' if test "$GCC" = "yes" ; then CFLAGS="$CFLAGS -mabi=n32" LDFLAGS="$LDFLAGS -mabi=n32" else case $system in IRIX-6.3) # Use to build 6.2 compatible binaries on 6.3. CFLAGS="$CFLAGS -n32 -D_OLD_TERMIOS" ;; *) CFLAGS="$CFLAGS -n32" ;; esac LDFLAGS="$LDFLAGS -n32" fi ;; IRIX64-6.*) SHLIB_CFLAGS="" SHLIB_LD="ld -n32 -shared -rdata_shared" SHLIB_LD_LIBS='${LIBS}' SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}' # Check to enable 64-bit flags for compiler/linker if test "$do64bit" = "yes" ; then if test "$GCC" = "yes" ; then { echo "$as_me:$LINENO: WARNING: 64bit mode not supported by gcc" >&5 echo "$as_me: WARNING: 64bit mode not supported by gcc" >&2;} else do64bit_ok=yes SHLIB_LD="ld -64 -shared -rdata_shared" CFLAGS="$CFLAGS -64" LDFLAGS_ARCH="-64" fi fi ;; Linux*) SHLIB_CFLAGS="-fPIC" SHLIB_LD_LIBS='${LIBS}' SHLIB_SUFFIX=".so" CFLAGS_OPTIMIZE="-O2 -fomit-frame-pointer" # egcs-2.91.66 on Redhat Linux 6.0 generates lots of warnings # when you inline the string and math operations. Turn this off to # get rid of the warnings. #CFLAGS_OPTIMIZE="${CFLAGS_OPTIMIZE} -D__NO_STRING_INLINES -D__NO_MATH_INLINES" SHLIB_LD="${CC} -shared" DL_OBJS="tclLoadDl.o" DL_LIBS="-ldl" LDFLAGS="$LDFLAGS -Wl,--export-dynamic" CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} if test "`uname -m`" = "alpha" ; then CFLAGS="$CFLAGS -mieee" fi # The combo of gcc + glibc has a bug related # to inlining of functions like strtod(). The # -fno-builtin flag should address this problem # but it does not work. The -fno-inline flag # is kind of overkill but it works. # Disable inlining only when one of the # files in compat/*.c is being linked in. if test x"${USE_COMPAT}" != x ; then CFLAGS="$CFLAGS -fno-inline" fi ;; GNU*) SHLIB_CFLAGS="-fPIC" SHLIB_LD_LIBS='${LIBS}' SHLIB_SUFFIX=".so" SHLIB_LD="${CC} -shared" DL_OBJS="" DL_LIBS="-ldl" LDFLAGS="$LDFLAGS -Wl,--export-dynamic" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" if test "`uname -m`" = "alpha" ; then CFLAGS="$CFLAGS -mieee" fi ;; Lynx*) SHLIB_CFLAGS="-fPIC" SHLIB_LD_LIBS='${LIBS}' SHLIB_SUFFIX=".so" CFLAGS_OPTIMIZE=-02 SHLIB_LD="${CC} -shared " DL_OBJS="tclLoadDl.o" DL_LIBS="-mshared -ldl" LD_FLAGS="-Wl,--export-dynamic" CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' LD_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' ;; MP-RAS-02*) SHLIB_CFLAGS="-K PIC" SHLIB_LD="cc -G" SHLIB_LD_LIBS="" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="-ldl" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; MP-RAS-*) SHLIB_CFLAGS="-K PIC" SHLIB_LD="cc -G" SHLIB_LD_LIBS="" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="-ldl" LDFLAGS="$LDFLAGS -Wl,-Bexport" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; NetBSD-*|FreeBSD-[1-2].*) # NetBSD/SPARC needs -fPIC, -fpic will not do. SHLIB_CFLAGS="-fPIC" SHLIB_LD="ld -Bshareable -x" SHLIB_LD_LIBS="" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}' echo "$as_me:$LINENO: checking for ELF" >&5 echo $ECHO_N "checking for ELF... $ECHO_C" >&6 if test "${tcl_cv_ld_elf+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #ifdef __ELF__ yes #endif _ACEOF if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | $EGREP "yes" >/dev/null 2>&1; then tcl_cv_ld_elf=yes else tcl_cv_ld_elf=no fi rm -f conftest* fi echo "$as_me:$LINENO: result: $tcl_cv_ld_elf" >&5 echo "${ECHO_T}$tcl_cv_ld_elf" >&6 if test $tcl_cv_ld_elf = yes; then SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.so' else SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.so.1.0' fi # Ancient FreeBSD doesn't handle version numbers with dots. UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.a' TCL_LIB_VERSIONS_OK=nodots ;; OpenBSD-*) # OpenBSD/SPARC[64] needs -fPIC, -fpic will not do. case `machine` in sparc|sparc64) SHLIB_CFLAGS="-fPIC";; *) SHLIB_CFLAGS="-fpic";; esac SHLIB_LD="${CC} -shared ${SHLIB_CFLAGS}" SHLIB_LD_LIBS='${LIBS}' SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.so.1.0' echo "$as_me:$LINENO: checking for ELF" >&5 echo $ECHO_N "checking for ELF... $ECHO_C" >&6 if test "${tcl_cv_ld_elf+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #ifdef __ELF__ yes #endif _ACEOF if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | $EGREP "yes" >/dev/null 2>&1; then tcl_cv_ld_elf=yes else tcl_cv_ld_elf=no fi rm -f conftest* fi echo "$as_me:$LINENO: result: $tcl_cv_ld_elf" >&5 echo "${ECHO_T}$tcl_cv_ld_elf" >&6 if test $tcl_cv_ld_elf = yes; then LDFLAGS=-Wl,-export-dynamic else LDFLAGS="" fi # OpenBSD doesn't do version numbers with dots. UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.a' TCL_LIB_VERSIONS_OK=nodots ;; FreeBSD-*) # FreeBSD 3.* and greater have ELF. SHLIB_CFLAGS="-fPIC" SHLIB_LD="ld -Bshareable -x" SHLIB_LD_LIBS='${LIBS}' SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" LDFLAGS="$LDFLAGS -export-dynamic" CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}' if test "${TCL_THREADS}" = "1" ; then # The -pthread needs to go in the CFLAGS, not LIBS LIBS=`echo $LIBS | sed s/-pthread//` CFLAGS="$CFLAGS -pthread" LDFLAGS="$LDFLAGS -pthread" fi case $system in FreeBSD-3.*) # FreeBSD-3 doesn't handle version numbers with dots. UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.a' SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.so' TCL_LIB_VERSIONS_OK=nodots ;; esac ;; Darwin-*) CFLAGS_OPTIMIZE="-Os" SHLIB_CFLAGS="-fno-common" if test $do64bit = yes; then do64bit_ok=yes CFLAGS="$CFLAGS -arch ppc64 -mpowerpc64 -mcpu=G5" fi # TEA specific: use LDFLAGS_DEFAULT instead of LDFLAGS here: SHLIB_LD='${CC} -dynamiclib ${CFLAGS} ${LDFLAGS_DEFAULT}' echo "$as_me:$LINENO: checking if ld accepts -single_module flag" >&5 echo $ECHO_N "checking if ld accepts -single_module flag... $ECHO_C" >&6 if test "${tcl_cv_ld_single_module+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else hold_ldflags=$LDFLAGS LDFLAGS="$LDFLAGS -dynamiclib -Wl,-single_module" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int main () { int i; ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then tcl_cv_ld_single_module=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 tcl_cv_ld_single_module=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LDFLAGS=$hold_ldflags fi echo "$as_me:$LINENO: result: $tcl_cv_ld_single_module" >&5 echo "${ECHO_T}$tcl_cv_ld_single_module" >&6 if test $tcl_cv_ld_single_module = yes; then SHLIB_LD="${SHLIB_LD} -Wl,-single_module" fi SHLIB_LD_LIBS='${LIBS}' SHLIB_SUFFIX=".dylib" DL_OBJS="tclLoadDyld.o" DL_LIBS="" # Don't use -prebind when building for Mac OS X 10.4 or later only: test -z "${MACOSX_DEPLOYMENT_TARGET}" || \ test "`echo "${MACOSX_DEPLOYMENT_TARGET}" | awk -F. '{print $2}'`" -lt 4 && \ LDFLAGS="$LDFLAGS -prebind" LDFLAGS="$LDFLAGS -headerpad_max_install_names" echo "$as_me:$LINENO: checking if ld accepts -search_paths_first flag" >&5 echo $ECHO_N "checking if ld accepts -search_paths_first flag... $ECHO_C" >&6 if test "${tcl_cv_ld_search_paths_first+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else hold_ldflags=$LDFLAGS LDFLAGS="$LDFLAGS -Wl,-search_paths_first" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int main () { int i; ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then tcl_cv_ld_search_paths_first=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 tcl_cv_ld_search_paths_first=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LDFLAGS=$hold_ldflags fi echo "$as_me:$LINENO: result: $tcl_cv_ld_search_paths_first" >&5 echo "${ECHO_T}$tcl_cv_ld_search_paths_first" >&6 if test $tcl_cv_ld_search_paths_first = yes; then LDFLAGS="$LDFLAGS -Wl,-search_paths_first" fi CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" LD_LIBRARY_PATH_VAR="DYLD_LIBRARY_PATH" # TEA specific: for Tk extensions, remove -arch ppc64 from CFLAGS # for fat builds, as neither TkAqua nor TkX11 can be built for 64bit # at present (no 64bit GUI libraries). test $do64bit_ok = no && test -n "${TK_BIN_DIR}" && \ CFLAGS="`echo "$CFLAGS" | sed -e 's/-arch ppc64/-arch ppc/g'`" ;; NEXTSTEP-*) SHLIB_CFLAGS="" SHLIB_LD="cc -nostdlib -r" SHLIB_LD_LIBS="" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadNext.o" DL_LIBS="" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; OS/390-*) CFLAGS_OPTIMIZE="" # Optimizer is buggy cat >>confdefs.h <<\_ACEOF #define _OE_SOCKETS 1 _ACEOF ;; OSF1-1.0|OSF1-1.1|OSF1-1.2) # OSF/1 1.[012] from OSF, and derivatives, including Paragon OSF/1 SHLIB_CFLAGS="" # Hack: make package name same as library name SHLIB_LD='ld -R -export :' SHLIB_LD_LIBS="" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadOSF.o" DL_LIBS="" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; OSF1-1.*) # OSF/1 1.3 from OSF using ELF, and derivatives, including AD2 SHLIB_CFLAGS="-fPIC" if test "$SHARED_BUILD" = "1" ; then SHLIB_LD="ld -shared" else SHLIB_LD="ld -non_shared" fi SHLIB_LD_LIBS="" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; OSF1-V*) # Digital OSF/1 SHLIB_CFLAGS="" if test "$SHARED_BUILD" = "1" ; then SHLIB_LD='ld -shared -expect_unresolved "*"' else SHLIB_LD='ld -non_shared -expect_unresolved "*"' fi SHLIB_LD_LIBS="" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}' if test "$GCC" = "yes" ; then CFLAGS="$CFLAGS -mieee" else CFLAGS="$CFLAGS -DHAVE_TZSET -std1 -ieee" fi # see pthread_intro(3) for pthread support on osf1, k.furukawa if test "${TCL_THREADS}" = "1" ; then CFLAGS="$CFLAGS -DHAVE_PTHREAD_ATTR_SETSTACKSIZE" CFLAGS="$CFLAGS -DTCL_THREAD_STACK_MIN=PTHREAD_STACK_MIN*64" LIBS=`echo $LIBS | sed s/-lpthreads//` if test "$GCC" = "yes" ; then LIBS="$LIBS -lpthread -lmach -lexc" else CFLAGS="$CFLAGS -pthread" LDFLAGS="$LDFLAGS -pthread" fi fi ;; QNX-6*) # QNX RTP # This may work for all QNX, but it was only reported for v6. SHLIB_CFLAGS="-fPIC" SHLIB_LD="ld -Bshareable -x" SHLIB_LD_LIBS="" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" # dlopen is in -lc on QNX DL_LIBS="" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; SCO_SV-3.2*) # Note, dlopen is available only on SCO 3.2.5 and greater. However, # this test works, since "uname -s" was non-standard in 3.2.4 and # below. if test "$GCC" = "yes" ; then SHLIB_CFLAGS="-fPIC -melf" LDFLAGS="$LDFLAGS -melf -Wl,-Bexport" else SHLIB_CFLAGS="-Kpic -belf" LDFLAGS="$LDFLAGS -belf -Wl,-Bexport" fi SHLIB_LD="ld -G" SHLIB_LD_LIBS="" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; SINIX*5.4*) SHLIB_CFLAGS="-K PIC" SHLIB_LD="cc -G" SHLIB_LD_LIBS="" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="-ldl" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; SunOS-4*) SHLIB_CFLAGS="-PIC" SHLIB_LD="ld" SHLIB_LD_LIBS="" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="-ldl" CC_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}' LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} # SunOS can't handle version numbers with dots in them in library # specs, like -ltcl7.5, so use -ltcl75 instead. Also, it # requires an extra version number at the end of .so file names. # So, the library has to have a name like libtcl75.so.1.0 SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.so.1.0' UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.a' TCL_LIB_VERSIONS_OK=nodots ;; SunOS-5.[0-6]) # Careful to not let 5.10+ fall into this case # Note: If _REENTRANT isn't defined, then Solaris # won't define thread-safe library routines. cat >>confdefs.h <<\_ACEOF #define _REENTRANT 1 _ACEOF cat >>confdefs.h <<\_ACEOF #define _POSIX_PTHREAD_SEMANTICS 1 _ACEOF SHLIB_CFLAGS="-KPIC" # Note: need the LIBS below, otherwise Tk won't find Tcl's # symbols when dynamically loaded into tclsh. SHLIB_LD_LIBS='${LIBS}' SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="-ldl" if test "$GCC" = "yes" ; then SHLIB_LD="$CC -shared" CC_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}' LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} else SHLIB_LD="/usr/ccs/bin/ld -G -z text" CC_SEARCH_FLAGS='-R ${LIB_RUNTIME_DIR}' LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} fi ;; SunOS-5*) # Note: If _REENTRANT isn't defined, then Solaris # won't define thread-safe library routines. cat >>confdefs.h <<\_ACEOF #define _REENTRANT 1 _ACEOF cat >>confdefs.h <<\_ACEOF #define _POSIX_PTHREAD_SEMANTICS 1 _ACEOF SHLIB_CFLAGS="-KPIC" # Check to enable 64-bit flags for compiler/linker if test "$do64bit" = "yes" ; then arch=`isainfo` if test "$arch" = "sparcv9 sparc" ; then if test "$GCC" = "yes" ; then if test "`gcc -dumpversion | awk -F. '{print $1}'`" -lt "3" ; then { echo "$as_me:$LINENO: WARNING: 64bit mode not supported with GCC < 3.2 on $system" >&5 echo "$as_me: WARNING: 64bit mode not supported with GCC < 3.2 on $system" >&2;} else do64bit_ok=yes CFLAGS="$CFLAGS -m64 -mcpu=v9" LDFLAGS="$LDFLAGS -m64 -mcpu=v9" SHLIB_CFLAGS="-fPIC" fi else do64bit_ok=yes if test "$do64bitVIS" = "yes" ; then CFLAGS="$CFLAGS -xarch=v9a" LDFLAGS_ARCH="-xarch=v9a" else CFLAGS="$CFLAGS -xarch=v9" LDFLAGS_ARCH="-xarch=v9" fi # Solaris 64 uses this as well #LD_LIBRARY_PATH_VAR="LD_LIBRARY_PATH_64" fi elif test "$arch" = "amd64 i386" ; then if test "$GCC" = "yes" ; then { echo "$as_me:$LINENO: WARNING: 64bit mode not supported with GCC on $system" >&5 echo "$as_me: WARNING: 64bit mode not supported with GCC on $system" >&2;} else do64bit_ok=yes CFLAGS="$CFLAGS -xarch=amd64" LDFLAGS="$LDFLAGS -xarch=amd64" fi else { echo "$as_me:$LINENO: WARNING: 64bit mode not supported for $arch" >&5 echo "$as_me: WARNING: 64bit mode not supported for $arch" >&2;} fi fi # Note: need the LIBS below, otherwise Tk won't find Tcl's # symbols when dynamically loaded into tclsh. SHLIB_LD_LIBS='${LIBS}' SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="-ldl" if test "$GCC" = "yes" ; then SHLIB_LD="$CC -shared" CC_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}' LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} if test "$do64bit_ok" = "yes" ; then # We need to specify -static-libgcc or we need to # add the path to the sparv9 libgcc. # JH: static-libgcc is necessary for core Tcl, but may # not be necessary for extensions. SHLIB_LD="$SHLIB_LD -m64 -mcpu=v9 -static-libgcc" # for finding sparcv9 libgcc, get the regular libgcc # path, remove so name and append 'sparcv9' #v9gcclibdir="`gcc -print-file-name=libgcc_s.so` | ..." #CC_SEARCH_FLAGS="${CC_SEARCH_FLAGS},-R,$v9gcclibdir" fi else SHLIB_LD="/usr/ccs/bin/ld -G -z text" CC_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}' LD_SEARCH_FLAGS='-R ${LIB_RUNTIME_DIR}' fi ;; UNIX_SV* | UnixWare-5*) SHLIB_CFLAGS="-KPIC" SHLIB_LD="cc -G" SHLIB_LD_LIBS="" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="-ldl" # Some UNIX_SV* systems (unixware 1.1.2 for example) have linkers # that don't grok the -Bexport option. Test that it does. echo "$as_me:$LINENO: checking for ld accepts -Bexport flag" >&5 echo $ECHO_N "checking for ld accepts -Bexport flag... $ECHO_C" >&6 if test "${tcl_cv_ld_Bexport+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else hold_ldflags=$LDFLAGS LDFLAGS="$LDFLAGS -Wl,-Bexport" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int main () { int i; ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then tcl_cv_ld_Bexport=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 tcl_cv_ld_Bexport=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LDFLAGS=$hold_ldflags fi echo "$as_me:$LINENO: result: $tcl_cv_ld_Bexport" >&5 echo "${ECHO_T}$tcl_cv_ld_Bexport" >&6 if test $tcl_cv_ld_Bexport = yes; then LDFLAGS="$LDFLAGS -Wl,-Bexport" fi CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; esac if test "$do64bit" = "yes" -a "$do64bit_ok" = "no" ; then { echo "$as_me:$LINENO: WARNING: 64bit support being disabled -- don't know magic for this platform" >&5 echo "$as_me: WARNING: 64bit support being disabled -- don't know magic for this platform" >&2;} fi # Step 4: disable dynamic loading if requested via a command-line switch. # Check whether --enable-load or --disable-load was given. if test "${enable_load+set}" = set; then enableval="$enable_load" tcl_ok=$enableval else tcl_ok=yes fi; if test "$tcl_ok" = "no"; then DL_OBJS="" fi if test "x$DL_OBJS" != "x" ; then BUILD_DLTEST="\$(DLTEST_TARGETS)" else echo "Can't figure out how to do dynamic loading or shared libraries" echo "on this system." SHLIB_CFLAGS="" SHLIB_LD="" SHLIB_SUFFIX="" DL_OBJS="tclLoadNone.o" DL_LIBS="" LDFLAGS="$LDFLAGS_ORIG" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" BUILD_DLTEST="" fi LDFLAGS="$LDFLAGS $LDFLAGS_ARCH" # If we're running gcc, then change the C flags for compiling shared # libraries to the right flags for gcc, instead of those for the # standard manufacturer compiler. if test "$DL_OBJS" != "tclLoadNone.o" ; then if test "$GCC" = "yes" ; then case $system in AIX-*) ;; BSD/OS*) ;; IRIX*) ;; NetBSD-*|FreeBSD-*) ;; Darwin-*) ;; SCO_SV-3.2*) ;; windows) ;; *) SHLIB_CFLAGS="-fPIC" ;; esac fi fi if test "$SHARED_LIB_SUFFIX" = "" ; then SHARED_LIB_SUFFIX='${PACKAGE_VERSION}${SHLIB_SUFFIX}' fi if test "$UNSHARED_LIB_SUFFIX" = "" ; then UNSHARED_LIB_SUFFIX='${PACKAGE_VERSION}.a' fi # These must be called after we do the basic CFLAGS checks and # verify any possible 64-bit or similar switches are necessary echo "$as_me:$LINENO: checking for required early compiler flags" >&5 echo $ECHO_N "checking for required early compiler flags... $ECHO_C" >&6 tcl_flags="" if test "${tcl_cv_flag__isoc99_source+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { char *p = (char *)strtoll; char *q = (char *)strtoull; ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then tcl_cv_flag__isoc99_source=no else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #define _ISOC99_SOURCE 1 #include int main () { char *p = (char *)strtoll; char *q = (char *)strtoull; ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then tcl_cv_flag__isoc99_source=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 tcl_cv_flag__isoc99_source=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi if test "x${tcl_cv_flag__isoc99_source}" = "xyes" ; then cat >>confdefs.h <<\_ACEOF #define _ISOC99_SOURCE 1 _ACEOF tcl_flags="$tcl_flags _ISOC99_SOURCE" fi if test "${tcl_cv_flag__largefile64_source+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { struct stat64 buf; int i = stat64("/", &buf); ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then tcl_cv_flag__largefile64_source=no else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #define _LARGEFILE64_SOURCE 1 #include int main () { struct stat64 buf; int i = stat64("/", &buf); ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then tcl_cv_flag__largefile64_source=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 tcl_cv_flag__largefile64_source=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi if test "x${tcl_cv_flag__largefile64_source}" = "xyes" ; then cat >>confdefs.h <<\_ACEOF #define _LARGEFILE64_SOURCE 1 _ACEOF tcl_flags="$tcl_flags _LARGEFILE64_SOURCE" fi if test "${tcl_cv_flag__largefile_source64+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { char *p = (char *)open64; ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then tcl_cv_flag__largefile_source64=no else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #define _LARGEFILE_SOURCE64 1 #include int main () { char *p = (char *)open64; ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then tcl_cv_flag__largefile_source64=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 tcl_cv_flag__largefile_source64=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi if test "x${tcl_cv_flag__largefile_source64}" = "xyes" ; then cat >>confdefs.h <<\_ACEOF #define _LARGEFILE_SOURCE64 1 _ACEOF tcl_flags="$tcl_flags _LARGEFILE_SOURCE64" fi if test "x${tcl_flags}" = "x" ; then echo "$as_me:$LINENO: result: none" >&5 echo "${ECHO_T}none" >&6 else echo "$as_me:$LINENO: result: ${tcl_flags}" >&5 echo "${ECHO_T}${tcl_flags}" >&6 fi echo "$as_me:$LINENO: checking for 64-bit integer type" >&5 echo $ECHO_N "checking for 64-bit integer type... $ECHO_C" >&6 if test "${tcl_cv_type_64bit+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else tcl_cv_type_64bit=none # See if the compiler knows natively about __int64 cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int main () { __int64 value = (__int64) 0; ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then tcl_type_64bit=__int64 else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 tcl_type_64bit="long long" fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext # See if we should use long anyway Note that we substitute in the # type that is our current guess for a 64-bit type inside this check # program, so it should be modified only carefully... cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int main () { switch (0) { case 1: case (sizeof(${tcl_type_64bit})==sizeof(long)): ; } ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then tcl_cv_type_64bit=${tcl_type_64bit} else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi if test "${tcl_cv_type_64bit}" = none ; then cat >>confdefs.h <<\_ACEOF #define TCL_WIDE_INT_IS_LONG 1 _ACEOF echo "$as_me:$LINENO: result: using long" >&5 echo "${ECHO_T}using long" >&6 elif test "${tcl_cv_type_64bit}" = "__int64" \ -a "${TEA_PLATFORM}" = "windows" ; then # We actually want to use the default tcl.h checks in this # case to handle both TCL_WIDE_INT_TYPE and TCL_LL_MODIFIER* echo "$as_me:$LINENO: result: using Tcl header defaults" >&5 echo "${ECHO_T}using Tcl header defaults" >&6 else cat >>confdefs.h <<_ACEOF #define TCL_WIDE_INT_TYPE ${tcl_cv_type_64bit} _ACEOF echo "$as_me:$LINENO: result: ${tcl_cv_type_64bit}" >&5 echo "${ECHO_T}${tcl_cv_type_64bit}" >&6 # Now check for auxiliary declarations echo "$as_me:$LINENO: checking for struct dirent64" >&5 echo $ECHO_N "checking for struct dirent64... $ECHO_C" >&6 if test "${tcl_cv_struct_dirent64+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include int main () { struct dirent64 p; ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then tcl_cv_struct_dirent64=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 tcl_cv_struct_dirent64=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $tcl_cv_struct_dirent64" >&5 echo "${ECHO_T}$tcl_cv_struct_dirent64" >&6 if test "x${tcl_cv_struct_dirent64}" = "xyes" ; then cat >>confdefs.h <<\_ACEOF #define HAVE_STRUCT_DIRENT64 1 _ACEOF fi echo "$as_me:$LINENO: checking for struct stat64" >&5 echo $ECHO_N "checking for struct stat64... $ECHO_C" >&6 if test "${tcl_cv_struct_stat64+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { struct stat64 p; ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then tcl_cv_struct_stat64=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 tcl_cv_struct_stat64=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $tcl_cv_struct_stat64" >&5 echo "${ECHO_T}$tcl_cv_struct_stat64" >&6 if test "x${tcl_cv_struct_stat64}" = "xyes" ; then cat >>confdefs.h <<\_ACEOF #define HAVE_STRUCT_STAT64 1 _ACEOF fi for ac_func in open64 lseek64 do as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh` echo "$as_me:$LINENO: checking for $ac_func" >&5 echo $ECHO_N "checking for $ac_func... $ECHO_C" >&6 if eval "test \"\${$as_ac_var+set}\" = set"; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Define $ac_func to an innocuous variant, in case declares $ac_func. For example, HP-UX 11i declares gettimeofday. */ #define $ac_func innocuous_$ac_func /* System header to define __stub macros and hopefully few prototypes, which can conflict with char $ac_func (); below. Prefer to if __STDC__ is defined, since exists even on freestanding compilers. */ #ifdef __STDC__ # include #else # include #endif #undef $ac_func /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" { #endif /* We use char because int might match the return type of a gcc2 builtin and then its argument prototype would still apply. */ char $ac_func (); /* The GNU C library defines this for functions which it implements to always fail with ENOSYS. Some functions are actually named something starting with __ and the normal name is an alias. */ #if defined (__stub_$ac_func) || defined (__stub___$ac_func) choke me #else char (*f) () = $ac_func; #endif #ifdef __cplusplus } #endif int main () { return f != $ac_func; ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then eval "$as_ac_var=yes" else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 eval "$as_ac_var=no" fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext fi echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_var'}'`" >&5 echo "${ECHO_T}`eval echo '${'$as_ac_var'}'`" >&6 if test `eval echo '${'$as_ac_var'}'` = yes; then cat >>confdefs.h <<_ACEOF #define `echo "HAVE_$ac_func" | $as_tr_cpp` 1 _ACEOF fi done echo "$as_me:$LINENO: checking for off64_t" >&5 echo $ECHO_N "checking for off64_t... $ECHO_C" >&6 if test "${tcl_cv_type_off64_t+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { off64_t offset; ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then tcl_cv_type_off64_t=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 tcl_cv_type_off64_t=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi if test "x${tcl_cv_type_off64_t}" = "xyes" && \ test "x${ac_cv_func_lseek64}" = "xyes" && \ test "x${ac_cv_func_open64}" = "xyes" ; then cat >>confdefs.h <<\_ACEOF #define HAVE_TYPE_OFF64_T 1 _ACEOF echo "$as_me:$LINENO: result: yes" >&5 echo "${ECHO_T}yes" >&6 else echo "$as_me:$LINENO: result: no" >&5 echo "${ECHO_T}no" >&6 fi fi #-------------------------------------------------------------------- # Set the default compiler switches based on the --enable-symbols option. #-------------------------------------------------------------------- echo "$as_me:$LINENO: checking for build with symbols" >&5 echo $ECHO_N "checking for build with symbols... $ECHO_C" >&6 # Check whether --enable-symbols or --disable-symbols was given. if test "${enable_symbols+set}" = set; then enableval="$enable_symbols" tcl_ok=$enableval else tcl_ok=no fi; DBGX="" if test "$tcl_ok" = "no"; then CFLAGS_DEFAULT="${CFLAGS_OPTIMIZE}" LDFLAGS_DEFAULT="${LDFLAGS_OPTIMIZE}" echo "$as_me:$LINENO: result: no" >&5 echo "${ECHO_T}no" >&6 else CFLAGS_DEFAULT="${CFLAGS_DEBUG}" LDFLAGS_DEFAULT="${LDFLAGS_DEBUG}" if test "$tcl_ok" = "yes"; then echo "$as_me:$LINENO: result: yes (standard debugging)" >&5 echo "${ECHO_T}yes (standard debugging)" >&6 fi fi if test "${TEA_PLATFORM}" != "windows" ; then LDFLAGS_DEFAULT="${LDFLAGS}" fi if test "$tcl_ok" = "mem" -o "$tcl_ok" = "all"; then cat >>confdefs.h <<\_ACEOF #define TCL_MEM_DEBUG 1 _ACEOF fi if test "$tcl_ok" != "yes" -a "$tcl_ok" != "no"; then if test "$tcl_ok" = "all"; then echo "$as_me:$LINENO: result: enabled symbols mem debugging" >&5 echo "${ECHO_T}enabled symbols mem debugging" >&6 else echo "$as_me:$LINENO: result: enabled $tcl_ok debugging" >&5 echo "${ECHO_T}enabled $tcl_ok debugging" >&6 fi fi #-------------------------------------------------------------------- # Everyone should be linking against the Tcl stub library. If you # can't for some reason, remove this definition. If you aren't using # stubs, you also need to modify the SHLIB_LD_LIBS setting below to # link against the non-stubbed Tcl library. Add Tk too if necessary. #-------------------------------------------------------------------- cat >>confdefs.h <<\_ACEOF #define USE_TCL_STUBS 1 _ACEOF #-------------------------------------------------------------------- # START Special case checks #-------------------------------------------------------------------- if test "${TEA_PLATFORM}" = "unix" ; then #------------------------------------------------------------------------- # Check for system header files. #------------------------------------------------------------------------- if test "${ac_cv_header_sys_select_h+set}" = set; then echo "$as_me:$LINENO: checking for sys/select.h" >&5 echo $ECHO_N "checking for sys/select.h... $ECHO_C" >&6 if test "${ac_cv_header_sys_select_h+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 fi echo "$as_me:$LINENO: result: $ac_cv_header_sys_select_h" >&5 echo "${ECHO_T}$ac_cv_header_sys_select_h" >&6 else # Is the header compilable? echo "$as_me:$LINENO: checking sys/select.h usability" >&5 echo $ECHO_N "checking sys/select.h usability... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_includes_default #include _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_header_compiler=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_compiler=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 echo "${ECHO_T}$ac_header_compiler" >&6 # Is the header present? echo "$as_me:$LINENO: checking sys/select.h presence" >&5 echo $ECHO_N "checking sys/select.h presence... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include _ACEOF if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5 (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null; then if test -s conftest.err; then ac_cpp_err=$ac_c_preproc_warn_flag ac_cpp_err=$ac_cpp_err$ac_c_werror_flag else ac_cpp_err= fi else ac_cpp_err=yes fi if test -z "$ac_cpp_err"; then ac_header_preproc=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_preproc=no fi rm -f conftest.err conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 echo "${ECHO_T}$ac_header_preproc" >&6 # So? What about this header? case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in yes:no: ) { echo "$as_me:$LINENO: WARNING: sys/select.h: accepted by the compiler, rejected by the preprocessor!" >&5 echo "$as_me: WARNING: sys/select.h: accepted by the compiler, rejected by the preprocessor!" >&2;} { echo "$as_me:$LINENO: WARNING: sys/select.h: proceeding with the compiler's result" >&5 echo "$as_me: WARNING: sys/select.h: proceeding with the compiler's result" >&2;} ac_header_preproc=yes ;; no:yes:* ) { echo "$as_me:$LINENO: WARNING: sys/select.h: present but cannot be compiled" >&5 echo "$as_me: WARNING: sys/select.h: present but cannot be compiled" >&2;} { echo "$as_me:$LINENO: WARNING: sys/select.h: check for missing prerequisite headers?" >&5 echo "$as_me: WARNING: sys/select.h: check for missing prerequisite headers?" >&2;} { echo "$as_me:$LINENO: WARNING: sys/select.h: see the Autoconf documentation" >&5 echo "$as_me: WARNING: sys/select.h: see the Autoconf documentation" >&2;} { echo "$as_me:$LINENO: WARNING: sys/select.h: section \"Present But Cannot Be Compiled\"" >&5 echo "$as_me: WARNING: sys/select.h: section \"Present But Cannot Be Compiled\"" >&2;} { echo "$as_me:$LINENO: WARNING: sys/select.h: proceeding with the preprocessor's result" >&5 echo "$as_me: WARNING: sys/select.h: proceeding with the preprocessor's result" >&2;} { echo "$as_me:$LINENO: WARNING: sys/select.h: in the future, the compiler will take precedence" >&5 echo "$as_me: WARNING: sys/select.h: in the future, the compiler will take precedence" >&2;} ( cat <<\_ASBOX ## ------------------------------- ## ## Report this to the tclx lists. ## ## ------------------------------- ## _ASBOX ) | sed "s/^/$as_me: WARNING: /" >&2 ;; esac echo "$as_me:$LINENO: checking for sys/select.h" >&5 echo $ECHO_N "checking for sys/select.h... $ECHO_C" >&6 if test "${ac_cv_header_sys_select_h+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_cv_header_sys_select_h=$ac_header_preproc fi echo "$as_me:$LINENO: result: $ac_cv_header_sys_select_h" >&5 echo "${ECHO_T}$ac_cv_header_sys_select_h" >&6 fi if test $ac_cv_header_sys_select_h = yes; then cat >>confdefs.h <<\_ACEOF #define HAVE_SYS_SELECT_H 1 _ACEOF fi #------------------------------------------------------------------------- # What type do signals return? #------------------------------------------------------------------------- echo "$as_me:$LINENO: checking return type of signal handlers" >&5 echo $ECHO_N "checking return type of signal handlers... $ECHO_C" >&6 if test "${ac_cv_type_signal+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #ifdef signal # undef signal #endif #ifdef __cplusplus extern "C" void (*signal (int, void (*)(int)))(int); #else void (*signal ()) (); #endif int main () { int i; ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_type_signal=void else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_type_signal=int fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_type_signal" >&5 echo "${ECHO_T}$ac_cv_type_signal" >&6 cat >>confdefs.h <<_ACEOF #define RETSIGTYPE $ac_cv_type_signal _ACEOF #------------------------------------------------------------------------- # Find out all about time handling differences. #------------------------------------------------------------------------- echo "$as_me:$LINENO: checking whether struct tm is in sys/time.h or time.h" >&5 echo $ECHO_N "checking whether struct tm is in sys/time.h or time.h... $ECHO_C" >&6 if test "${ac_cv_struct_tm+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include int main () { struct tm *tp; tp->tm_sec; ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_struct_tm=time.h else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_struct_tm=sys/time.h fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_struct_tm" >&5 echo "${ECHO_T}$ac_cv_struct_tm" >&6 if test $ac_cv_struct_tm = sys/time.h; then cat >>confdefs.h <<\_ACEOF #define TM_IN_SYS_TIME 1 _ACEOF fi for ac_header in sys/time.h do as_ac_Header=`echo "ac_cv_header_$ac_header" | $as_tr_sh` if eval "test \"\${$as_ac_Header+set}\" = set"; then echo "$as_me:$LINENO: checking for $ac_header" >&5 echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6 if eval "test \"\${$as_ac_Header+set}\" = set"; then echo $ECHO_N "(cached) $ECHO_C" >&6 fi echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5 echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6 else # Is the header compilable? echo "$as_me:$LINENO: checking $ac_header usability" >&5 echo $ECHO_N "checking $ac_header usability... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_includes_default #include <$ac_header> _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_header_compiler=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_compiler=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 echo "${ECHO_T}$ac_header_compiler" >&6 # Is the header present? echo "$as_me:$LINENO: checking $ac_header presence" >&5 echo $ECHO_N "checking $ac_header presence... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include <$ac_header> _ACEOF if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5 (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null; then if test -s conftest.err; then ac_cpp_err=$ac_c_preproc_warn_flag ac_cpp_err=$ac_cpp_err$ac_c_werror_flag else ac_cpp_err= fi else ac_cpp_err=yes fi if test -z "$ac_cpp_err"; then ac_header_preproc=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_preproc=no fi rm -f conftest.err conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 echo "${ECHO_T}$ac_header_preproc" >&6 # So? What about this header? case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in yes:no: ) { echo "$as_me:$LINENO: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&5 echo "$as_me: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&2;} { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the compiler's result" >&5 echo "$as_me: WARNING: $ac_header: proceeding with the compiler's result" >&2;} ac_header_preproc=yes ;; no:yes:* ) { echo "$as_me:$LINENO: WARNING: $ac_header: present but cannot be compiled" >&5 echo "$as_me: WARNING: $ac_header: present but cannot be compiled" >&2;} { echo "$as_me:$LINENO: WARNING: $ac_header: check for missing prerequisite headers?" >&5 echo "$as_me: WARNING: $ac_header: check for missing prerequisite headers?" >&2;} { echo "$as_me:$LINENO: WARNING: $ac_header: see the Autoconf documentation" >&5 echo "$as_me: WARNING: $ac_header: see the Autoconf documentation" >&2;} { echo "$as_me:$LINENO: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&5 echo "$as_me: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&2;} { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the preprocessor's result" >&5 echo "$as_me: WARNING: $ac_header: proceeding with the preprocessor's result" >&2;} { echo "$as_me:$LINENO: WARNING: $ac_header: in the future, the compiler will take precedence" >&5 echo "$as_me: WARNING: $ac_header: in the future, the compiler will take precedence" >&2;} ( cat <<\_ASBOX ## ------------------------------- ## ## Report this to the tclx lists. ## ## ------------------------------- ## _ASBOX ) | sed "s/^/$as_me: WARNING: /" >&2 ;; esac echo "$as_me:$LINENO: checking for $ac_header" >&5 echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6 if eval "test \"\${$as_ac_Header+set}\" = set"; then echo $ECHO_N "(cached) $ECHO_C" >&6 else eval "$as_ac_Header=\$ac_header_preproc" fi echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5 echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6 fi if test `eval echo '${'$as_ac_Header'}'` = yes; then cat >>confdefs.h <<_ACEOF #define `echo "HAVE_$ac_header" | $as_tr_cpp` 1 _ACEOF fi done echo "$as_me:$LINENO: checking whether time.h and sys/time.h may both be included" >&5 echo $ECHO_N "checking whether time.h and sys/time.h may both be included... $ECHO_C" >&6 if test "${ac_cv_header_time+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include int main () { if ((struct tm *) 0) return 0; ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_header_time=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_header_time=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_header_time" >&5 echo "${ECHO_T}$ac_cv_header_time" >&6 if test $ac_cv_header_time = yes; then cat >>confdefs.h <<\_ACEOF #define TIME_WITH_SYS_TIME 1 _ACEOF fi echo "$as_me:$LINENO: checking for struct tm.tm_zone" >&5 echo $ECHO_N "checking for struct tm.tm_zone... $ECHO_C" >&6 if test "${ac_cv_member_struct_tm_tm_zone+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include <$ac_cv_struct_tm> int main () { static struct tm ac_aggr; if (ac_aggr.tm_zone) return 0; ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_member_struct_tm_tm_zone=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include <$ac_cv_struct_tm> int main () { static struct tm ac_aggr; if (sizeof ac_aggr.tm_zone) return 0; ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_member_struct_tm_tm_zone=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_member_struct_tm_tm_zone=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_member_struct_tm_tm_zone" >&5 echo "${ECHO_T}$ac_cv_member_struct_tm_tm_zone" >&6 if test $ac_cv_member_struct_tm_tm_zone = yes; then cat >>confdefs.h <<_ACEOF #define HAVE_STRUCT_TM_TM_ZONE 1 _ACEOF fi if test "$ac_cv_member_struct_tm_tm_zone" = yes; then cat >>confdefs.h <<\_ACEOF #define HAVE_TM_ZONE 1 _ACEOF else echo "$as_me:$LINENO: checking for tzname" >&5 echo $ECHO_N "checking for tzname... $ECHO_C" >&6 if test "${ac_cv_var_tzname+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #ifndef tzname /* For SGI. */ extern char *tzname[]; /* RS6000 and others reject char **tzname. */ #endif int main () { atoi(*tzname); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_var_tzname=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_var_tzname=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_var_tzname" >&5 echo "${ECHO_T}$ac_cv_var_tzname" >&6 if test $ac_cv_var_tzname = yes; then cat >>confdefs.h <<\_ACEOF #define HAVE_TZNAME 1 _ACEOF fi fi for ac_func in gmtime_r localtime_r do as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh` echo "$as_me:$LINENO: checking for $ac_func" >&5 echo $ECHO_N "checking for $ac_func... $ECHO_C" >&6 if eval "test \"\${$as_ac_var+set}\" = set"; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Define $ac_func to an innocuous variant, in case declares $ac_func. For example, HP-UX 11i declares gettimeofday. */ #define $ac_func innocuous_$ac_func /* System header to define __stub macros and hopefully few prototypes, which can conflict with char $ac_func (); below. Prefer to if __STDC__ is defined, since exists even on freestanding compilers. */ #ifdef __STDC__ # include #else # include #endif #undef $ac_func /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" { #endif /* We use char because int might match the return type of a gcc2 builtin and then its argument prototype would still apply. */ char $ac_func (); /* The GNU C library defines this for functions which it implements to always fail with ENOSYS. Some functions are actually named something starting with __ and the normal name is an alias. */ #if defined (__stub_$ac_func) || defined (__stub___$ac_func) choke me #else char (*f) () = $ac_func; #endif #ifdef __cplusplus } #endif int main () { return f != $ac_func; ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then eval "$as_ac_var=yes" else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 eval "$as_ac_var=no" fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext fi echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_var'}'`" >&5 echo "${ECHO_T}`eval echo '${'$as_ac_var'}'`" >&6 if test `eval echo '${'$as_ac_var'}'` = yes; then cat >>confdefs.h <<_ACEOF #define `echo "HAVE_$ac_func" | $as_tr_cpp` 1 _ACEOF fi done echo "$as_me:$LINENO: checking tm_tzadj in struct tm" >&5 echo $ECHO_N "checking tm_tzadj in struct tm... $ECHO_C" >&6 if test "${tcl_cv_member_tm_tzadj+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { struct tm tm; tm.tm_tzadj; ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then tcl_cv_member_tm_tzadj=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 tcl_cv_member_tm_tzadj=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $tcl_cv_member_tm_tzadj" >&5 echo "${ECHO_T}$tcl_cv_member_tm_tzadj" >&6 if test $tcl_cv_member_tm_tzadj = yes ; then cat >>confdefs.h <<\_ACEOF #define HAVE_TM_TZADJ 1 _ACEOF fi echo "$as_me:$LINENO: checking tm_gmtoff in struct tm" >&5 echo $ECHO_N "checking tm_gmtoff in struct tm... $ECHO_C" >&6 if test "${tcl_cv_member_tm_gmtoff+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { struct tm tm; tm.tm_gmtoff; ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then tcl_cv_member_tm_gmtoff=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 tcl_cv_member_tm_gmtoff=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $tcl_cv_member_tm_gmtoff" >&5 echo "${ECHO_T}$tcl_cv_member_tm_gmtoff" >&6 if test $tcl_cv_member_tm_gmtoff = yes ; then cat >>confdefs.h <<\_ACEOF #define HAVE_TM_GMTOFF 1 _ACEOF fi # # Its important to include time.h in this check, as some systems # (like convex) have timezone functions, etc. # echo "$as_me:$LINENO: checking long timezone variable" >&5 echo $ECHO_N "checking long timezone variable... $ECHO_C" >&6 if test "${tcl_cv_timezone_long+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { extern long timezone; timezone += 1; exit (0); ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then tcl_cv_timezone_long=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 tcl_cv_timezone_long=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $tcl_cv_timezone_long" >&5 echo "${ECHO_T}$tcl_cv_timezone_long" >&6 if test $tcl_cv_timezone_long = yes ; then cat >>confdefs.h <<\_ACEOF #define HAVE_TIMEZONE_VAR 1 _ACEOF else # # On some systems (eg IRIX 6.2), timezone is a time_t and not a long. # echo "$as_me:$LINENO: checking time_t timezone variable" >&5 echo $ECHO_N "checking time_t timezone variable... $ECHO_C" >&6 if test "${tcl_cv_timezone_time+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { extern time_t timezone; timezone += 1; exit (0); ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then tcl_cv_timezone_time=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 tcl_cv_timezone_time=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $tcl_cv_timezone_time" >&5 echo "${ECHO_T}$tcl_cv_timezone_time" >&6 if test $tcl_cv_timezone_time = yes ; then cat >>confdefs.h <<\_ACEOF #define HAVE_TIMEZONE_VAR 1 _ACEOF fi fi #-------------------------------------------------------------------- # The check below checks whether defines the type # "union wait" correctly. It's needed because of weirdness in # HP-UX where "union wait" is defined in both the BSD and SYS-V # environments. Checking the usability of WIFEXITED seems to do # the trick. #-------------------------------------------------------------------- echo "$as_me:$LINENO: checking union wait" >&5 echo $ECHO_N "checking union wait... $ECHO_C" >&6 if test "${tcl_cv_union_wait+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include int main () { union wait x; WIFEXITED(x); /* Generates compiler error if WIFEXITED uses an int. */ ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then tcl_cv_union_wait=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 tcl_cv_union_wait=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $tcl_cv_union_wait" >&5 echo "${ECHO_T}$tcl_cv_union_wait" >&6 if test $tcl_cv_union_wait = no; then cat >>confdefs.h <<\_ACEOF #define NO_UNION_WAIT 1 _ACEOF fi #------------------------------------------------------------------------- # Test to see if "times" returns a status or the amount of elapsed real # time. #------------------------------------------------------------------------- echo "$as_me:$LINENO: checking checking to see what 'times' returns" >&5 echo $ECHO_N "checking checking to see what 'times' returns... $ECHO_C" >&6 if test "$cross_compiling" = yes; then { { echo "$as_me:$LINENO: error: cross-compiling not supported" >&5 echo "$as_me: error: cross-compiling not supported" >&2;} { (exit 1); exit 1; }; } else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include main() { struct tms cpu; times(&cpu); sleep(2); exit ((times(&cpu) > 0) ? 0 : 1); } _ACEOF rm -f conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='./conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then echo "$as_me:$LINENO: result: elapsed real time" >&5 echo "${ECHO_T}elapsed real time" >&6 else echo "$as_me: program exited with status $ac_status" >&5 echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ( exit $ac_status ) echo "$as_me:$LINENO: result: a status" >&5 echo "${ECHO_T}a status" >&6 cat >>confdefs.h <<\_ACEOF #define TIMES_RETS_STATUS 1 _ACEOF fi rm -f core *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext fi #------------------------------------------------------------------------- # Check for missing typedefs. #------------------------------------------------------------------------- #AC_CHECK_TYPE(clock_t, long) echo "$as_me:$LINENO: checking for time_t" >&5 echo $ECHO_N "checking for time_t... $ECHO_C" >&6 if test "${ac_cv_type_time_t+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_includes_default int main () { if ((time_t *) 0) return 0; if (sizeof (time_t)) return 0; ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_type_time_t=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_type_time_t=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_type_time_t" >&5 echo "${ECHO_T}$ac_cv_type_time_t" >&6 if test $ac_cv_type_time_t = yes; then : else cat >>confdefs.h <<_ACEOF #define time_t long _ACEOF fi echo "$as_me:$LINENO: checking for off_t" >&5 echo $ECHO_N "checking for off_t... $ECHO_C" >&6 if test "${ac_cv_type_off_t+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_includes_default int main () { if ((off_t *) 0) return 0; if (sizeof (off_t)) return 0; ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_type_off_t=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_type_off_t=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_type_off_t" >&5 echo "${ECHO_T}$ac_cv_type_off_t" >&6 if test $ac_cv_type_off_t = yes; then : else cat >>confdefs.h <<_ACEOF #define off_t long _ACEOF fi #------------------------------------------------------------------------- # Older SCO systems don't have ftruncate, but have chsize in libx. Newer # versions have both. Only check for chsize in libx if we don't have # truncate. #------------------------------------------------------------------------- echo "$as_me:$LINENO: checking for ftruncate" >&5 echo $ECHO_N "checking for ftruncate... $ECHO_C" >&6 if test "${ac_cv_func_ftruncate+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Define ftruncate to an innocuous variant, in case declares ftruncate. For example, HP-UX 11i declares gettimeofday. */ #define ftruncate innocuous_ftruncate /* System header to define __stub macros and hopefully few prototypes, which can conflict with char ftruncate (); below. Prefer to if __STDC__ is defined, since exists even on freestanding compilers. */ #ifdef __STDC__ # include #else # include #endif #undef ftruncate /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" { #endif /* We use char because int might match the return type of a gcc2 builtin and then its argument prototype would still apply. */ char ftruncate (); /* The GNU C library defines this for functions which it implements to always fail with ENOSYS. Some functions are actually named something starting with __ and the normal name is an alias. */ #if defined (__stub_ftruncate) || defined (__stub___ftruncate) choke me #else char (*f) () = ftruncate; #endif #ifdef __cplusplus } #endif int main () { return f != ftruncate; ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_func_ftruncate=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_func_ftruncate=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_func_ftruncate" >&5 echo "${ECHO_T}$ac_cv_func_ftruncate" >&6 if test $ac_cv_func_ftruncate = yes; then : else cat >>confdefs.h <<\_ACEOF #define NO_FTRUNCATE 1 _ACEOF echo "$as_me:$LINENO: checking for chsize in -lx" >&5 echo $ECHO_N "checking for chsize in -lx... $ECHO_C" >&6 if test "${ac_cv_lib_x_chsize+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lx $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" #endif /* We use char because int might match the return type of a gcc2 builtin and then its argument prototype would still apply. */ char chsize (); int main () { chsize (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_lib_x_chsize=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_x_chsize=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi echo "$as_me:$LINENO: result: $ac_cv_lib_x_chsize" >&5 echo "${ECHO_T}$ac_cv_lib_x_chsize" >&6 if test $ac_cv_lib_x_chsize = yes; then cat >>confdefs.h <<\_ACEOF #define HAVE_CHSIZE 1 _ACEOF vars="-lx" for i in $vars; do if test "${TEA_PLATFORM}" = "windows" -a "$GCC" = "yes" ; then # Convert foo.lib to -lfoo for GCC. No-op if not *.lib i=`echo "$i" | sed -e 's/^\([^-].*\)\.lib$/-l\1/i'` fi PKG_LIBS="$PKG_LIBS $i" done fi fi #------------------------------------------------------------------------- # Check for various Unix or library functions that can be used by TclX. # These must be after the library checks. #------------------------------------------------------------------------- echo "$as_me:$LINENO: checking for select" >&5 echo $ECHO_N "checking for select... $ECHO_C" >&6 if test "${ac_cv_func_select+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Define select to an innocuous variant, in case declares select. For example, HP-UX 11i declares gettimeofday. */ #define select innocuous_select /* System header to define __stub macros and hopefully few prototypes, which can conflict with char select (); below. Prefer to if __STDC__ is defined, since exists even on freestanding compilers. */ #ifdef __STDC__ # include #else # include #endif #undef select /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" { #endif /* We use char because int might match the return type of a gcc2 builtin and then its argument prototype would still apply. */ char select (); /* The GNU C library defines this for functions which it implements to always fail with ENOSYS. Some functions are actually named something starting with __ and the normal name is an alias. */ #if defined (__stub_select) || defined (__stub___select) choke me #else char (*f) () = select; #endif #ifdef __cplusplus } #endif int main () { return f != select; ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_func_select=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_func_select=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_func_select" >&5 echo "${ECHO_T}$ac_cv_func_select" >&6 if test $ac_cv_func_select = yes; then : else cat >>confdefs.h <<\_ACEOF #define NO_SELECT 1 _ACEOF fi echo "$as_me:$LINENO: checking for setitimer" >&5 echo $ECHO_N "checking for setitimer... $ECHO_C" >&6 if test "${ac_cv_func_setitimer+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Define setitimer to an innocuous variant, in case declares setitimer. For example, HP-UX 11i declares gettimeofday. */ #define setitimer innocuous_setitimer /* System header to define __stub macros and hopefully few prototypes, which can conflict with char setitimer (); below. Prefer to if __STDC__ is defined, since exists even on freestanding compilers. */ #ifdef __STDC__ # include #else # include #endif #undef setitimer /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" { #endif /* We use char because int might match the return type of a gcc2 builtin and then its argument prototype would still apply. */ char setitimer (); /* The GNU C library defines this for functions which it implements to always fail with ENOSYS. Some functions are actually named something starting with __ and the normal name is an alias. */ #if defined (__stub_setitimer) || defined (__stub___setitimer) choke me #else char (*f) () = setitimer; #endif #ifdef __cplusplus } #endif int main () { return f != setitimer; ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_func_setitimer=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_func_setitimer=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_func_setitimer" >&5 echo "${ECHO_T}$ac_cv_func_setitimer" >&6 if test $ac_cv_func_setitimer = yes; then : else cat >>confdefs.h <<\_ACEOF #define NO_SETITIMER 1 _ACEOF fi echo "$as_me:$LINENO: checking for sigaction" >&5 echo $ECHO_N "checking for sigaction... $ECHO_C" >&6 if test "${ac_cv_func_sigaction+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Define sigaction to an innocuous variant, in case declares sigaction. For example, HP-UX 11i declares gettimeofday. */ #define sigaction innocuous_sigaction /* System header to define __stub macros and hopefully few prototypes, which can conflict with char sigaction (); below. Prefer to if __STDC__ is defined, since exists even on freestanding compilers. */ #ifdef __STDC__ # include #else # include #endif #undef sigaction /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" { #endif /* We use char because int might match the return type of a gcc2 builtin and then its argument prototype would still apply. */ char sigaction (); /* The GNU C library defines this for functions which it implements to always fail with ENOSYS. Some functions are actually named something starting with __ and the normal name is an alias. */ #if defined (__stub_sigaction) || defined (__stub___sigaction) choke me #else char (*f) () = sigaction; #endif #ifdef __cplusplus } #endif int main () { return f != sigaction; ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_func_sigaction=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_func_sigaction=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_func_sigaction" >&5 echo "${ECHO_T}$ac_cv_func_sigaction" >&6 if test $ac_cv_func_sigaction = yes; then : else cat >>confdefs.h <<\_ACEOF #define NO_SIGACTION 1 _ACEOF fi echo "$as_me:$LINENO: checking for setpgid" >&5 echo $ECHO_N "checking for setpgid... $ECHO_C" >&6 if test "${ac_cv_func_setpgid+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Define setpgid to an innocuous variant, in case declares setpgid. For example, HP-UX 11i declares gettimeofday. */ #define setpgid innocuous_setpgid /* System header to define __stub macros and hopefully few prototypes, which can conflict with char setpgid (); below. Prefer to if __STDC__ is defined, since exists even on freestanding compilers. */ #ifdef __STDC__ # include #else # include #endif #undef setpgid /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" { #endif /* We use char because int might match the return type of a gcc2 builtin and then its argument prototype would still apply. */ char setpgid (); /* The GNU C library defines this for functions which it implements to always fail with ENOSYS. Some functions are actually named something starting with __ and the normal name is an alias. */ #if defined (__stub_setpgid) || defined (__stub___setpgid) choke me #else char (*f) () = setpgid; #endif #ifdef __cplusplus } #endif int main () { return f != setpgid; ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_func_setpgid=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_func_setpgid=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_func_setpgid" >&5 echo "${ECHO_T}$ac_cv_func_setpgid" >&6 if test $ac_cv_func_setpgid = yes; then : else cat >>confdefs.h <<\_ACEOF #define NO_SETPGID 1 _ACEOF fi echo "$as_me:$LINENO: checking for getgroups" >&5 echo $ECHO_N "checking for getgroups... $ECHO_C" >&6 if test "${ac_cv_func_getgroups+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Define getgroups to an innocuous variant, in case declares getgroups. For example, HP-UX 11i declares gettimeofday. */ #define getgroups innocuous_getgroups /* System header to define __stub macros and hopefully few prototypes, which can conflict with char getgroups (); below. Prefer to if __STDC__ is defined, since exists even on freestanding compilers. */ #ifdef __STDC__ # include #else # include #endif #undef getgroups /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" { #endif /* We use char because int might match the return type of a gcc2 builtin and then its argument prototype would still apply. */ char getgroups (); /* The GNU C library defines this for functions which it implements to always fail with ENOSYS. Some functions are actually named something starting with __ and the normal name is an alias. */ #if defined (__stub_getgroups) || defined (__stub___getgroups) choke me #else char (*f) () = getgroups; #endif #ifdef __cplusplus } #endif int main () { return f != getgroups; ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_func_getgroups=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_func_getgroups=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_func_getgroups" >&5 echo "${ECHO_T}$ac_cv_func_getgroups" >&6 if test $ac_cv_func_getgroups = yes; then : else cat >>confdefs.h <<\_ACEOF #define NO_GETGROUPS 1 _ACEOF fi echo "$as_me:$LINENO: checking for bzero" >&5 echo $ECHO_N "checking for bzero... $ECHO_C" >&6 if test "${ac_cv_func_bzero+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Define bzero to an innocuous variant, in case declares bzero. For example, HP-UX 11i declares gettimeofday. */ #define bzero innocuous_bzero /* System header to define __stub macros and hopefully few prototypes, which can conflict with char bzero (); below. Prefer to if __STDC__ is defined, since exists even on freestanding compilers. */ #ifdef __STDC__ # include #else # include #endif #undef bzero /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" { #endif /* We use char because int might match the return type of a gcc2 builtin and then its argument prototype would still apply. */ char bzero (); /* The GNU C library defines this for functions which it implements to always fail with ENOSYS. Some functions are actually named something starting with __ and the normal name is an alias. */ #if defined (__stub_bzero) || defined (__stub___bzero) choke me #else char (*f) () = bzero; #endif #ifdef __cplusplus } #endif int main () { return f != bzero; ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_func_bzero=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_func_bzero=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_func_bzero" >&5 echo "${ECHO_T}$ac_cv_func_bzero" >&6 if test $ac_cv_func_bzero = yes; then : else cat >>confdefs.h <<\_ACEOF #define NO_BZERO 1 _ACEOF fi echo "$as_me:$LINENO: checking for bcopy" >&5 echo $ECHO_N "checking for bcopy... $ECHO_C" >&6 if test "${ac_cv_func_bcopy+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Define bcopy to an innocuous variant, in case declares bcopy. For example, HP-UX 11i declares gettimeofday. */ #define bcopy innocuous_bcopy /* System header to define __stub macros and hopefully few prototypes, which can conflict with char bcopy (); below. Prefer to if __STDC__ is defined, since exists even on freestanding compilers. */ #ifdef __STDC__ # include #else # include #endif #undef bcopy /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" { #endif /* We use char because int might match the return type of a gcc2 builtin and then its argument prototype would still apply. */ char bcopy (); /* The GNU C library defines this for functions which it implements to always fail with ENOSYS. Some functions are actually named something starting with __ and the normal name is an alias. */ #if defined (__stub_bcopy) || defined (__stub___bcopy) choke me #else char (*f) () = bcopy; #endif #ifdef __cplusplus } #endif int main () { return f != bcopy; ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_func_bcopy=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_func_bcopy=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_func_bcopy" >&5 echo "${ECHO_T}$ac_cv_func_bcopy" >&6 if test $ac_cv_func_bcopy = yes; then : else cat >>confdefs.h <<\_ACEOF #define NO_BCOPY 1 _ACEOF fi echo "$as_me:$LINENO: checking for fsync" >&5 echo $ECHO_N "checking for fsync... $ECHO_C" >&6 if test "${ac_cv_func_fsync+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Define fsync to an innocuous variant, in case declares fsync. For example, HP-UX 11i declares gettimeofday. */ #define fsync innocuous_fsync /* System header to define __stub macros and hopefully few prototypes, which can conflict with char fsync (); below. Prefer to if __STDC__ is defined, since exists even on freestanding compilers. */ #ifdef __STDC__ # include #else # include #endif #undef fsync /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" { #endif /* We use char because int might match the return type of a gcc2 builtin and then its argument prototype would still apply. */ char fsync (); /* The GNU C library defines this for functions which it implements to always fail with ENOSYS. Some functions are actually named something starting with __ and the normal name is an alias. */ #if defined (__stub_fsync) || defined (__stub___fsync) choke me #else char (*f) () = fsync; #endif #ifdef __cplusplus } #endif int main () { return f != fsync; ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_func_fsync=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_func_fsync=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_func_fsync" >&5 echo "${ECHO_T}$ac_cv_func_fsync" >&6 if test $ac_cv_func_fsync = yes; then : else cat >>confdefs.h <<\_ACEOF #define NO_FSYNC 1 _ACEOF fi echo "$as_me:$LINENO: checking for getpriority" >&5 echo $ECHO_N "checking for getpriority... $ECHO_C" >&6 if test "${ac_cv_func_getpriority+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Define getpriority to an innocuous variant, in case declares getpriority. For example, HP-UX 11i declares gettimeofday. */ #define getpriority innocuous_getpriority /* System header to define __stub macros and hopefully few prototypes, which can conflict with char getpriority (); below. Prefer to if __STDC__ is defined, since exists even on freestanding compilers. */ #ifdef __STDC__ # include #else # include #endif #undef getpriority /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" { #endif /* We use char because int might match the return type of a gcc2 builtin and then its argument prototype would still apply. */ char getpriority (); /* The GNU C library defines this for functions which it implements to always fail with ENOSYS. Some functions are actually named something starting with __ and the normal name is an alias. */ #if defined (__stub_getpriority) || defined (__stub___getpriority) choke me #else char (*f) () = getpriority; #endif #ifdef __cplusplus } #endif int main () { return f != getpriority; ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_func_getpriority=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_func_getpriority=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_func_getpriority" >&5 echo "${ECHO_T}$ac_cv_func_getpriority" >&6 if test $ac_cv_func_getpriority = yes; then : else cat >>confdefs.h <<\_ACEOF #define NO_GETPRIORITY 1 _ACEOF fi echo "$as_me:$LINENO: checking for strcoll" >&5 echo $ECHO_N "checking for strcoll... $ECHO_C" >&6 if test "${ac_cv_func_strcoll+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Define strcoll to an innocuous variant, in case declares strcoll. For example, HP-UX 11i declares gettimeofday. */ #define strcoll innocuous_strcoll /* System header to define __stub macros and hopefully few prototypes, which can conflict with char strcoll (); below. Prefer to if __STDC__ is defined, since exists even on freestanding compilers. */ #ifdef __STDC__ # include #else # include #endif #undef strcoll /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" { #endif /* We use char because int might match the return type of a gcc2 builtin and then its argument prototype would still apply. */ char strcoll (); /* The GNU C library defines this for functions which it implements to always fail with ENOSYS. Some functions are actually named something starting with __ and the normal name is an alias. */ #if defined (__stub_strcoll) || defined (__stub___strcoll) choke me #else char (*f) () = strcoll; #endif #ifdef __cplusplus } #endif int main () { return f != strcoll; ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_func_strcoll=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_func_strcoll=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_func_strcoll" >&5 echo "${ECHO_T}$ac_cv_func_strcoll" >&6 if test $ac_cv_func_strcoll = yes; then : else cat >>confdefs.h <<\_ACEOF #define NO_STRCOLL 1 _ACEOF fi echo "$as_me:$LINENO: checking for fchown" >&5 echo $ECHO_N "checking for fchown... $ECHO_C" >&6 if test "${ac_cv_func_fchown+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Define fchown to an innocuous variant, in case declares fchown. For example, HP-UX 11i declares gettimeofday. */ #define fchown innocuous_fchown /* System header to define __stub macros and hopefully few prototypes, which can conflict with char fchown (); below. Prefer to if __STDC__ is defined, since exists even on freestanding compilers. */ #ifdef __STDC__ # include #else # include #endif #undef fchown /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" { #endif /* We use char because int might match the return type of a gcc2 builtin and then its argument prototype would still apply. */ char fchown (); /* The GNU C library defines this for functions which it implements to always fail with ENOSYS. Some functions are actually named something starting with __ and the normal name is an alias. */ #if defined (__stub_fchown) || defined (__stub___fchown) choke me #else char (*f) () = fchown; #endif #ifdef __cplusplus } #endif int main () { return f != fchown; ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_func_fchown=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_func_fchown=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_func_fchown" >&5 echo "${ECHO_T}$ac_cv_func_fchown" >&6 if test $ac_cv_func_fchown = yes; then : else cat >>confdefs.h <<\_ACEOF #define NO_FCHOWN 1 _ACEOF fi echo "$as_me:$LINENO: checking for fchmod" >&5 echo $ECHO_N "checking for fchmod... $ECHO_C" >&6 if test "${ac_cv_func_fchmod+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Define fchmod to an innocuous variant, in case declares fchmod. For example, HP-UX 11i declares gettimeofday. */ #define fchmod innocuous_fchmod /* System header to define __stub macros and hopefully few prototypes, which can conflict with char fchmod (); below. Prefer to if __STDC__ is defined, since exists even on freestanding compilers. */ #ifdef __STDC__ # include #else # include #endif #undef fchmod /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" { #endif /* We use char because int might match the return type of a gcc2 builtin and then its argument prototype would still apply. */ char fchmod (); /* The GNU C library defines this for functions which it implements to always fail with ENOSYS. Some functions are actually named something starting with __ and the normal name is an alias. */ #if defined (__stub_fchmod) || defined (__stub___fchmod) choke me #else char (*f) () = fchmod; #endif #ifdef __cplusplus } #endif int main () { return f != fchmod; ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_func_fchmod=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_func_fchmod=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_func_fchmod" >&5 echo "${ECHO_T}$ac_cv_func_fchmod" >&6 if test $ac_cv_func_fchmod = yes; then : else cat >>confdefs.h <<\_ACEOF #define NO_FCHMOD 1 _ACEOF fi echo "$as_me:$LINENO: checking for truncate" >&5 echo $ECHO_N "checking for truncate... $ECHO_C" >&6 if test "${ac_cv_func_truncate+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Define truncate to an innocuous variant, in case declares truncate. For example, HP-UX 11i declares gettimeofday. */ #define truncate innocuous_truncate /* System header to define __stub macros and hopefully few prototypes, which can conflict with char truncate (); below. Prefer to if __STDC__ is defined, since exists even on freestanding compilers. */ #ifdef __STDC__ # include #else # include #endif #undef truncate /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" { #endif /* We use char because int might match the return type of a gcc2 builtin and then its argument prototype would still apply. */ char truncate (); /* The GNU C library defines this for functions which it implements to always fail with ENOSYS. Some functions are actually named something starting with __ and the normal name is an alias. */ #if defined (__stub_truncate) || defined (__stub___truncate) choke me #else char (*f) () = truncate; #endif #ifdef __cplusplus } #endif int main () { return f != truncate; ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_func_truncate=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_func_truncate=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_func_truncate" >&5 echo "${ECHO_T}$ac_cv_func_truncate" >&6 if test $ac_cv_func_truncate = yes; then : else cat >>confdefs.h <<\_ACEOF #define NO_TRUNCATE 1 _ACEOF fi echo "$as_me:$LINENO: checking for waitpid" >&5 echo $ECHO_N "checking for waitpid... $ECHO_C" >&6 if test "${ac_cv_func_waitpid+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Define waitpid to an innocuous variant, in case declares waitpid. For example, HP-UX 11i declares gettimeofday. */ #define waitpid innocuous_waitpid /* System header to define __stub macros and hopefully few prototypes, which can conflict with char waitpid (); below. Prefer to if __STDC__ is defined, since exists even on freestanding compilers. */ #ifdef __STDC__ # include #else # include #endif #undef waitpid /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" { #endif /* We use char because int might match the return type of a gcc2 builtin and then its argument prototype would still apply. */ char waitpid (); /* The GNU C library defines this for functions which it implements to always fail with ENOSYS. Some functions are actually named something starting with __ and the normal name is an alias. */ #if defined (__stub_waitpid) || defined (__stub___waitpid) choke me #else char (*f) () = waitpid; #endif #ifdef __cplusplus } #endif int main () { return f != waitpid; ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_func_waitpid=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_func_waitpid=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_func_waitpid" >&5 echo "${ECHO_T}$ac_cv_func_waitpid" >&6 if test $ac_cv_func_waitpid = yes; then : else cat >>confdefs.h <<\_ACEOF #define NO_WAITPID 1 _ACEOF fi echo "$as_me:$LINENO: checking for sysconf" >&5 echo $ECHO_N "checking for sysconf... $ECHO_C" >&6 if test "${ac_cv_func_sysconf+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Define sysconf to an innocuous variant, in case declares sysconf. For example, HP-UX 11i declares gettimeofday. */ #define sysconf innocuous_sysconf /* System header to define __stub macros and hopefully few prototypes, which can conflict with char sysconf (); below. Prefer to if __STDC__ is defined, since exists even on freestanding compilers. */ #ifdef __STDC__ # include #else # include #endif #undef sysconf /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" { #endif /* We use char because int might match the return type of a gcc2 builtin and then its argument prototype would still apply. */ char sysconf (); /* The GNU C library defines this for functions which it implements to always fail with ENOSYS. Some functions are actually named something starting with __ and the normal name is an alias. */ #if defined (__stub_sysconf) || defined (__stub___sysconf) choke me #else char (*f) () = sysconf; #endif #ifdef __cplusplus } #endif int main () { return f != sysconf; ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_func_sysconf=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_func_sysconf=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_func_sysconf" >&5 echo "${ECHO_T}$ac_cv_func_sysconf" >&6 if test $ac_cv_func_sysconf = yes; then : else cat >>confdefs.h <<\_ACEOF #define NO_SYSCONF 1 _ACEOF fi #------------------------------------------------------------------------- # Test for socket related functions. #------------------------------------------------------------------------- echo "$as_me:$LINENO: checking for inet_aton" >&5 echo $ECHO_N "checking for inet_aton... $ECHO_C" >&6 if test "${ac_cv_func_inet_aton+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Define inet_aton to an innocuous variant, in case declares inet_aton. For example, HP-UX 11i declares gettimeofday. */ #define inet_aton innocuous_inet_aton /* System header to define __stub macros and hopefully few prototypes, which can conflict with char inet_aton (); below. Prefer to if __STDC__ is defined, since exists even on freestanding compilers. */ #ifdef __STDC__ # include #else # include #endif #undef inet_aton /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" { #endif /* We use char because int might match the return type of a gcc2 builtin and then its argument prototype would still apply. */ char inet_aton (); /* The GNU C library defines this for functions which it implements to always fail with ENOSYS. Some functions are actually named something starting with __ and the normal name is an alias. */ #if defined (__stub_inet_aton) || defined (__stub___inet_aton) choke me #else char (*f) () = inet_aton; #endif #ifdef __cplusplus } #endif int main () { return f != inet_aton; ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_func_inet_aton=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_func_inet_aton=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_func_inet_aton" >&5 echo "${ECHO_T}$ac_cv_func_inet_aton" >&6 if test $ac_cv_func_inet_aton = yes; then : else cat >>confdefs.h <<\_ACEOF #define NO_INET_ATON 1 _ACEOF fi echo "$as_me:$LINENO: checking for gethostname" >&5 echo $ECHO_N "checking for gethostname... $ECHO_C" >&6 if test "${ac_cv_func_gethostname+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Define gethostname to an innocuous variant, in case declares gethostname. For example, HP-UX 11i declares gettimeofday. */ #define gethostname innocuous_gethostname /* System header to define __stub macros and hopefully few prototypes, which can conflict with char gethostname (); below. Prefer to if __STDC__ is defined, since exists even on freestanding compilers. */ #ifdef __STDC__ # include #else # include #endif #undef gethostname /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" { #endif /* We use char because int might match the return type of a gcc2 builtin and then its argument prototype would still apply. */ char gethostname (); /* The GNU C library defines this for functions which it implements to always fail with ENOSYS. Some functions are actually named something starting with __ and the normal name is an alias. */ #if defined (__stub_gethostname) || defined (__stub___gethostname) choke me #else char (*f) () = gethostname; #endif #ifdef __cplusplus } #endif int main () { return f != gethostname; ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_func_gethostname=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_func_gethostname=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_func_gethostname" >&5 echo "${ECHO_T}$ac_cv_func_gethostname" >&6 if test $ac_cv_func_gethostname = yes; then : else cat >>confdefs.h <<\_ACEOF #define NO_GETHOSTNAME 1 _ACEOF fi #------------------------------------------------------------------------- # Check for additional libraries the Tcl/Tk does not check for. #------------------------------------------------------------------------- # This is needed for DEC Alphas echo "$as_me:$LINENO: checking for main in -ldnet_stub" >&5 echo $ECHO_N "checking for main in -ldnet_stub... $ECHO_C" >&6 if test "${ac_cv_lib_dnet_stub_main+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-ldnet_stub $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int main () { main (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_lib_dnet_stub_main=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_dnet_stub_main=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi echo "$as_me:$LINENO: result: $ac_cv_lib_dnet_stub_main" >&5 echo "${ECHO_T}$ac_cv_lib_dnet_stub_main" >&6 if test $ac_cv_lib_dnet_stub_main = yes; then vars="-ldnet_stub" for i in $vars; do if test "${TEA_PLATFORM}" = "windows" -a "$GCC" = "yes" ; then # Convert foo.lib to -lfoo for GCC. No-op if not *.lib i=`echo "$i" | sed -e 's/^\([^-].*\)\.lib$/-l\1/i'` fi PKG_LIBS="$PKG_LIBS $i" done fi #------------------------------------------------------------------------- # Check for catgets. Not the some systems (NetBSD 1.0) have catclose # declared as type void rather than type int. #------------------------------------------------------------------------- echo "$as_me:$LINENO: checking for catgets" >&5 echo $ECHO_N "checking for catgets... $ECHO_C" >&6 if test "${ac_cv_func_catgets+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Define catgets to an innocuous variant, in case declares catgets. For example, HP-UX 11i declares gettimeofday. */ #define catgets innocuous_catgets /* System header to define __stub macros and hopefully few prototypes, which can conflict with char catgets (); below. Prefer to if __STDC__ is defined, since exists even on freestanding compilers. */ #ifdef __STDC__ # include #else # include #endif #undef catgets /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" { #endif /* We use char because int might match the return type of a gcc2 builtin and then its argument prototype would still apply. */ char catgets (); /* The GNU C library defines this for functions which it implements to always fail with ENOSYS. Some functions are actually named something starting with __ and the normal name is an alias. */ #if defined (__stub_catgets) || defined (__stub___catgets) choke me #else char (*f) () = catgets; #endif #ifdef __cplusplus } #endif int main () { return f != catgets; ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_func_catgets=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_func_catgets=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_func_catgets" >&5 echo "${ECHO_T}$ac_cv_func_catgets" >&6 if test $ac_cv_func_catgets = yes; then echo "$as_me:$LINENO: checking catclose return value" >&5 echo $ECHO_N "checking catclose return value... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { if (catclose ((nl_catd) 0) == 0) exit (0); ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then echo "$as_me:$LINENO: result: ok" >&5 echo "${ECHO_T}ok" >&6 else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 echo "$as_me:$LINENO: result: broken catclose return type" >&5 echo "${ECHO_T}broken catclose return type" >&6 cat >>confdefs.h <<\_ACEOF #define BAD_CATCLOSE 1 _ACEOF fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext else cat >>confdefs.h <<\_ACEOF #define NO_CATGETS 1 _ACEOF fi fi # end Unix only checks #------------------------------------------------------------------------------ # Check for missing functions that we need. Must be done after library checks. #------------------------------------------------------------------------------ echo "$as_me:$LINENO: checking for random" >&5 echo $ECHO_N "checking for random... $ECHO_C" >&6 if test "${ac_cv_func_random+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Define random to an innocuous variant, in case declares random. For example, HP-UX 11i declares gettimeofday. */ #define random innocuous_random /* System header to define __stub macros and hopefully few prototypes, which can conflict with char random (); below. Prefer to if __STDC__ is defined, since exists even on freestanding compilers. */ #ifdef __STDC__ # include #else # include #endif #undef random /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" { #endif /* We use char because int might match the return type of a gcc2 builtin and then its argument prototype would still apply. */ char random (); /* The GNU C library defines this for functions which it implements to always fail with ENOSYS. Some functions are actually named something starting with __ and the normal name is an alias. */ #if defined (__stub_random) || defined (__stub___random) choke me #else char (*f) () = random; #endif #ifdef __cplusplus } #endif int main () { return f != random; ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_func_random=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_func_random=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_func_random" >&5 echo "${ECHO_T}$ac_cv_func_random" >&6 if test $ac_cv_func_random = yes; then : else case $LIBOBJS in "random.$ac_objext" | \ *" random.$ac_objext" | \ "random.$ac_objext "* | \ *" random.$ac_objext "* ) ;; *) LIBOBJS="$LIBOBJS random.$ac_objext" ;; esac cat >>confdefs.h <<\_ACEOF #define NO_RANDOM 1 _ACEOF fi #------------------------------------------------------------------------------ # Determine if random is declared in stdlib.h or math.h. If it is, we don't # want to redeclare it. Some systems, such as the DEC Alpha, have random # declared as returning int rather than long, since long is 64 bit. #------------------------------------------------------------------------------ found_random=NO cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include _ACEOF if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | $EGREP ""random"" >/dev/null 2>&1; then found_random=YES fi rm -f conftest* cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include _ACEOF if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | $EGREP ""random"" >/dev/null 2>&1; then found_random=YES fi rm -f conftest* if test "$found_random" = "NO"; then cat >>confdefs.h <<\_ACEOF #define NO_RANDOM_PROTO 1 _ACEOF fi #------------------------------------------------------------------------- # Allow --with-help to specify help file outputs #------------------------------------------------------------------------- echo "$as_me:$LINENO: checking where to place TclX help files" >&5 echo $ECHO_N "checking where to place TclX help files... $ECHO_C" >&6 # Check whether --with-help or --without-help was given. if test "${with_help+set}" = set; then withval="$with_help" with_help=${withval} else with_help=no fi; HELP_DIR=`pwd`/help BUILDHELP= if test x"${with_help}" = x"no" ; then echo "$as_me:$LINENO: result: do not build help files" >&5 echo "${ECHO_T}do not build help files" >&6 else if test x"${with_help}" != x -a x"${with_help}" != x"yes" ; then # Ensure that we don't catch --with-help by itself HELP_DIR=${with_help} fi #------------------------------------------------------------------------- # Determine if we have enough tools to generate the help files. #------------------------------------------------------------------------- echo "$as_me:$LINENO: result: ${HELP_DIR}" >&5 echo "${ECHO_T}${HELP_DIR}" >&6 # Extract the first word of "nroff", so it can be a program name with args. set dummy nroff; ac_word=$2 echo "$as_me:$LINENO: checking for $ac_word" >&5 echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 if test "${ac_cv_prog_NROFF+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else if test -n "$NROFF"; then ac_cv_prog_NROFF="$NROFF" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_NROFF="yes" echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done test -z "$ac_cv_prog_NROFF" && ac_cv_prog_NROFF="no" fi fi NROFF=$ac_cv_prog_NROFF if test -n "$NROFF"; then echo "$as_me:$LINENO: result: $NROFF" >&5 echo "${ECHO_T}$NROFF" >&6 else echo "$as_me:$LINENO: result: no" >&5 echo "${ECHO_T}no" >&6 fi # Extract the first word of "col", so it can be a program name with args. set dummy col; ac_word=$2 echo "$as_me:$LINENO: checking for $ac_word" >&5 echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 if test "${ac_cv_prog_COL+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else if test -n "$COL"; then ac_cv_prog_COL="$COL" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_COL="yes" echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done test -z "$ac_cv_prog_COL" && ac_cv_prog_COL="no" fi fi COL=$ac_cv_prog_COL if test -n "$COL"; then echo "$as_me:$LINENO: result: $COL" >&5 echo "${ECHO_T}$COL" >&6 else echo "$as_me:$LINENO: result: no" >&5 echo "${ECHO_T}no" >&6 fi if test "x${NROFF}" = "xno" -o "x${COL}" = "xno" ; then { echo "$as_me:$LINENO: WARNING: nroff or col executable missing. Cannot build TclX help." >&5 echo "$as_me: WARNING: nroff or col executable missing. Cannot build TclX help." >&2;} else BUILDHELP=buildhelp fi fi #-------------------------------------------------------------------- # End of special case checks #-------------------------------------------------------------------- #-------------------------------------------------------------------- # This macro generates a line to use when building a library. It # depends on values set by the TEA_ENABLE_SHARED, TEA_ENABLE_SYMBOLS, # and TEA_LOAD_TCLCONFIG macros above. #-------------------------------------------------------------------- if test "${TEA_PLATFORM}" = "windows" -a "$GCC" != "yes"; then MAKE_STATIC_LIB="\${STLIB_LD} -out:\$@ \$(PKG_OBJECTS)" MAKE_SHARED_LIB="\${SHLIB_LD} \${SHLIB_LD_LIBS} \${LDFLAGS_DEFAULT} -out:\$@ \$(PKG_OBJECTS)" MAKE_STUB_LIB="\${STLIB_LD} -out:\$@ \$(PKG_STUB_OBJECTS)" else MAKE_STATIC_LIB="\${STLIB_LD} \$@ \$(PKG_OBJECTS)" MAKE_SHARED_LIB="\${SHLIB_LD} -o \$@ \$(PKG_OBJECTS) \${SHLIB_LD_LIBS}" MAKE_STUB_LIB="\${STLIB_LD} \$@ \$(PKG_STUB_OBJECTS)" fi if test "${SHARED_BUILD}" = "1" ; then MAKE_LIB="${MAKE_SHARED_LIB} " else MAKE_LIB="${MAKE_STATIC_LIB} " fi #-------------------------------------------------------------------- # Shared libraries and static libraries have different names. # Use the double eval to make sure any variables in the suffix is # substituted. (@@@ Might not be necessary anymore) #-------------------------------------------------------------------- if test "${TEA_PLATFORM}" = "windows" ; then if test "${SHARED_BUILD}" = "1" ; then # We force the unresolved linking of symbols that are really in # the private libraries of Tcl and Tk. SHLIB_LD_LIBS="${SHLIB_LD_LIBS} \"`${CYGPATH} ${TCL_BIN_DIR}/${TCL_STUB_LIB_FILE}`\"" if test x"${TK_BIN_DIR}" != x ; then SHLIB_LD_LIBS="${SHLIB_LD_LIBS} \"`${CYGPATH} ${TK_BIN_DIR}/${TK_STUB_LIB_FILE}`\"" fi eval eval "PKG_LIB_FILE=${PACKAGE_NAME}${SHARED_LIB_SUFFIX}" else eval eval "PKG_LIB_FILE=${PACKAGE_NAME}${UNSHARED_LIB_SUFFIX}" fi # Some packages build their own stubs libraries eval eval "PKG_STUB_LIB_FILE=${PACKAGE_NAME}stub${UNSHARED_LIB_SUFFIX}" # These aren't needed on Windows (either MSVC or gcc) RANLIB=: RANLIB_STUB=: else RANLIB_STUB="${RANLIB}" if test "${SHARED_BUILD}" = "1" ; then SHLIB_LD_LIBS="${SHLIB_LD_LIBS} ${TCL_STUB_LIB_SPEC}" if test x"${TK_BIN_DIR}" != x ; then SHLIB_LD_LIBS="${SHLIB_LD_LIBS} ${TK_STUB_LIB_SPEC}" fi eval eval "PKG_LIB_FILE=lib${PACKAGE_NAME}${SHARED_LIB_SUFFIX}" RANLIB=: else eval eval "PKG_LIB_FILE=lib${PACKAGE_NAME}${UNSHARED_LIB_SUFFIX}" fi # Some packages build their own stubs libraries eval eval "PKG_STUB_LIB_FILE=lib${PACKAGE_NAME}stub${UNSHARED_LIB_SUFFIX}" fi # These are escaped so that only CFLAGS is picked up at configure time. # The other values will be substituted at make time. CFLAGS="${CFLAGS} \${CFLAGS_DEFAULT} \${CFLAGS_WARNING}" if test "${SHARED_BUILD}" = "1" ; then CFLAGS="${CFLAGS} \${SHLIB_CFLAGS}" fi #-------------------------------------------------------------------- # Find tclsh so that we can run pkg_mkIndex to generate the pkgIndex.tcl # file during the install process. Don't run the TCLSH_PROG through # ${CYGPATH} because it's being used directly by make. # Require that we use a tclsh shell version 8.2 or later since earlier # versions have bugs in the pkg_mkIndex routine. # Add WISH as well if this is a Tk extension. #-------------------------------------------------------------------- echo "$as_me:$LINENO: checking for tclsh" >&5 echo $ECHO_N "checking for tclsh... $ECHO_C" >&6 if test -f "${TCL_BIN_DIR}/Makefile" ; then # tclConfig.sh is in Tcl build directory if test "${TEA_PLATFORM}" = "windows"; then TCLSH_PROG="${TCL_BIN_DIR}/tclsh${TCL_MAJOR_VERSION}${TCL_MINOR_VERSION}${TCL_DBGX}${EXEEXT}" else TCLSH_PROG="${TCL_BIN_DIR}/tclsh" fi else # tclConfig.sh is in install location if test "${TEA_PLATFORM}" = "windows"; then TCLSH_PROG="tclsh${TCL_MAJOR_VERSION}${TCL_MINOR_VERSION}${TCL_DBGX}${EXEEXT}" else TCLSH_PROG="tclsh${TCL_MAJOR_VERSION}.${TCL_MINOR_VERSION}${TCL_DBGX}" fi list="`ls -d ${TCL_BIN_DIR}/../bin 2>/dev/null` \ `ls -d ${TCL_BIN_DIR}/.. 2>/dev/null` \ `ls -d ${TCL_PREFIX}/bin 2>/dev/null`" for i in $list ; do if test -f "$i/${TCLSH_PROG}" ; then REAL_TCL_BIN_DIR="`cd "$i"; pwd`" break fi done TCLSH_PROG="${REAL_TCL_BIN_DIR}/${TCLSH_PROG}" fi echo "$as_me:$LINENO: result: ${TCLSH_PROG}" >&5 echo "${ECHO_T}${TCLSH_PROG}" >&6 #-------------------------------------------------------------------- # Finally, substitute all of the various values into the Makefile. #-------------------------------------------------------------------- ac_config_files="$ac_config_files Makefile" cat >confcache <<\_ACEOF # This file is a shell script that caches the results of configure # tests run on this system so they can be shared between configure # scripts and configure runs, see configure's option --config-cache. # It is not useful on other systems. If it contains results you don't # want to keep, you may remove or edit it. # # config.status only pays attention to the cache file if you give it # the --recheck option to rerun configure. # # `ac_cv_env_foo' variables (set or unset) will be overridden when # loading this file, other *unset* `ac_cv_foo' will be assigned the # following values. _ACEOF # The following way of writing the cache mishandles newlines in values, # but we know of no workaround that is simple, portable, and efficient. # So, don't put newlines in cache variables' values. # Ultrix sh set writes to stderr and can't be redirected directly, # and sets the high bit in the cache file unless we assign to the vars. { (set) 2>&1 | case `(ac_space=' '; set | grep ac_space) 2>&1` in *ac_space=\ *) # `set' does not quote correctly, so add quotes (double-quote # substitution turns \\\\ into \\, and sed turns \\ into \). sed -n \ "s/'/'\\\\''/g; s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\\2'/p" ;; *) # `set' quotes correctly as required by POSIX, so do not add quotes. sed -n \ "s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1=\\2/p" ;; esac; } | sed ' t clear : clear s/^\([^=]*\)=\(.*[{}].*\)$/test "${\1+set}" = set || &/ t end /^ac_cv_env/!s/^\([^=]*\)=\(.*\)$/\1=${\1=\2}/ : end' >>confcache if diff $cache_file confcache >/dev/null 2>&1; then :; else if test -w $cache_file; then test "x$cache_file" != "x/dev/null" && echo "updating cache $cache_file" cat confcache >$cache_file else echo "not updating unwritable cache $cache_file" fi fi rm -f confcache test "x$prefix" = xNONE && prefix=$ac_default_prefix # Let make expand exec_prefix. test "x$exec_prefix" = xNONE && exec_prefix='${prefix}' # VPATH may cause trouble with some makes, so we remove $(srcdir), # ${srcdir} and @srcdir@ from VPATH if srcdir is ".", strip leading and # trailing colons and then remove the whole line if VPATH becomes empty # (actually we leave an empty line to preserve line numbers). if test "x$srcdir" = x.; then ac_vpsub='/^[ ]*VPATH[ ]*=/{ s/:*\$(srcdir):*/:/; s/:*\${srcdir}:*/:/; s/:*@srcdir@:*/:/; s/^\([^=]*=[ ]*\):*/\1/; s/:*$//; s/^[^=]*=[ ]*$//; }' fi # Transform confdefs.h into DEFS. # Protect against shell expansion while executing Makefile rules. # Protect against Makefile macro expansion. # # If the first sed substitution is executed (which looks for macros that # take arguments), then we branch to the quote section. Otherwise, # look for a macro that doesn't take arguments. cat >confdef2opt.sed <<\_ACEOF t clear : clear s,^[ ]*#[ ]*define[ ][ ]*\([^ (][^ (]*([^)]*)\)[ ]*\(.*\),-D\1=\2,g t quote s,^[ ]*#[ ]*define[ ][ ]*\([^ ][^ ]*\)[ ]*\(.*\),-D\1=\2,g t quote d : quote s,[ `~#$^&*(){}\\|;'"<>?],\\&,g s,\[,\\&,g s,\],\\&,g s,\$,$$,g p _ACEOF # We use echo to avoid assuming a particular line-breaking character. # The extra dot is to prevent the shell from consuming trailing # line-breaks from the sub-command output. A line-break within # single-quotes doesn't work because, if this script is created in a # platform that uses two characters for line-breaks (e.g., DOS), tr # would break. ac_LF_and_DOT=`echo; echo .` DEFS=`sed -n -f confdef2opt.sed confdefs.h | tr "$ac_LF_and_DOT" ' .'` rm -f confdef2opt.sed : ${CONFIG_STATUS=./config.status} ac_clean_files_save=$ac_clean_files ac_clean_files="$ac_clean_files $CONFIG_STATUS" { echo "$as_me:$LINENO: creating $CONFIG_STATUS" >&5 echo "$as_me: creating $CONFIG_STATUS" >&6;} cat >$CONFIG_STATUS <<_ACEOF #! $SHELL # Generated by $as_me. # Run this file to recreate the current configuration. # Compiler output produced by configure, useful for debugging # configure, is in config.log if it exists. debug=false ac_cs_recheck=false ac_cs_silent=false SHELL=\${CONFIG_SHELL-$SHELL} _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF ## --------------------- ## ## M4sh Initialization. ## ## --------------------- ## # Be Bourne compatible if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then emulate sh NULLCMD=: # Zsh 3.x and 4.x performs word splitting on ${1+"$@"}, which # is contrary to our usage. Disable this feature. alias -g '${1+"$@"}'='"$@"' elif test -n "${BASH_VERSION+set}" && (set -o posix) >/dev/null 2>&1; then set -o posix fi DUALCASE=1; export DUALCASE # for MKS sh # Support unset when possible. if ( (MAIL=60; unset MAIL) || exit) >/dev/null 2>&1; then as_unset=unset else as_unset=false fi # Work around bugs in pre-3.0 UWIN ksh. $as_unset ENV MAIL MAILPATH PS1='$ ' PS2='> ' PS4='+ ' # NLS nuisances. for as_var in \ LANG LANGUAGE LC_ADDRESS LC_ALL LC_COLLATE LC_CTYPE LC_IDENTIFICATION \ LC_MEASUREMENT LC_MESSAGES LC_MONETARY LC_NAME LC_NUMERIC LC_PAPER \ LC_TELEPHONE LC_TIME do if (set +x; test -z "`(eval $as_var=C; export $as_var) 2>&1`"); then eval $as_var=C; export $as_var else $as_unset $as_var fi done # Required to use basename. if expr a : '\(a\)' >/dev/null 2>&1; then as_expr=expr else as_expr=false fi if (basename /) >/dev/null 2>&1 && test "X`basename / 2>&1`" = "X/"; then as_basename=basename else as_basename=false fi # Name of the executable. as_me=`$as_basename "$0" || $as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ X"$0" : 'X\(//\)$' \| \ X"$0" : 'X\(/\)$' \| \ . : '\(.\)' 2>/dev/null || echo X/"$0" | sed '/^.*\/\([^/][^/]*\)\/*$/{ s//\1/; q; } /^X\/\(\/\/\)$/{ s//\1/; q; } /^X\/\(\/\).*/{ s//\1/; q; } s/.*/./; q'` # PATH needs CR, and LINENO needs CR and PATH. # Avoid depending upon Character Ranges. as_cr_letters='abcdefghijklmnopqrstuvwxyz' as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ' as_cr_Letters=$as_cr_letters$as_cr_LETTERS as_cr_digits='0123456789' as_cr_alnum=$as_cr_Letters$as_cr_digits # The user is always right. if test "${PATH_SEPARATOR+set}" != set; then echo "#! /bin/sh" >conf$$.sh echo "exit 0" >>conf$$.sh chmod +x conf$$.sh if (PATH="/nonexistent;."; conf$$.sh) >/dev/null 2>&1; then PATH_SEPARATOR=';' else PATH_SEPARATOR=: fi rm -f conf$$.sh fi as_lineno_1=$LINENO as_lineno_2=$LINENO as_lineno_3=`(expr $as_lineno_1 + 1) 2>/dev/null` test "x$as_lineno_1" != "x$as_lineno_2" && test "x$as_lineno_3" = "x$as_lineno_2" || { # Find who we are. Look in the path if we contain no path at all # relative or not. case $0 in *[\\/]* ) as_myself=$0 ;; *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break done ;; esac # We did not find ourselves, most probably we were run as `sh COMMAND' # in which case we are not to be found in the path. if test "x$as_myself" = x; then as_myself=$0 fi if test ! -f "$as_myself"; then { { echo "$as_me:$LINENO: error: cannot find myself; rerun with an absolute path" >&5 echo "$as_me: error: cannot find myself; rerun with an absolute path" >&2;} { (exit 1); exit 1; }; } fi case $CONFIG_SHELL in '') as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in /bin$PATH_SEPARATOR/usr/bin$PATH_SEPARATOR$PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for as_base in sh bash ksh sh5; do case $as_dir in /*) if ("$as_dir/$as_base" -c ' as_lineno_1=$LINENO as_lineno_2=$LINENO as_lineno_3=`(expr $as_lineno_1 + 1) 2>/dev/null` test "x$as_lineno_1" != "x$as_lineno_2" && test "x$as_lineno_3" = "x$as_lineno_2" ') 2>/dev/null; then $as_unset BASH_ENV || test "${BASH_ENV+set}" != set || { BASH_ENV=; export BASH_ENV; } $as_unset ENV || test "${ENV+set}" != set || { ENV=; export ENV; } CONFIG_SHELL=$as_dir/$as_base export CONFIG_SHELL exec "$CONFIG_SHELL" "$0" ${1+"$@"} fi;; esac done done ;; esac # Create $as_me.lineno as a copy of $as_myself, but with $LINENO # uniformly replaced by the line number. The first 'sed' inserts a # line-number line before each line; the second 'sed' does the real # work. The second script uses 'N' to pair each line-number line # with the numbered line, and appends trailing '-' during # substitution so that $LINENO is not a special case at line end. # (Raja R Harinath suggested sed '=', and Paul Eggert wrote the # second 'sed' script. Blame Lee E. McMahon for sed's syntax. :-) sed '=' <$as_myself | sed ' N s,$,-, : loop s,^\(['$as_cr_digits']*\)\(.*\)[$]LINENO\([^'$as_cr_alnum'_]\),\1\2\1\3, t loop s,-$,, s,^['$as_cr_digits']*\n,, ' >$as_me.lineno && chmod +x $as_me.lineno || { { echo "$as_me:$LINENO: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&5 echo "$as_me: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&2;} { (exit 1); exit 1; }; } # Don't try to exec as it changes $[0], causing all sort of problems # (the dirname of $[0] is not the place where we might find the # original and so on. Autoconf is especially sensible to this). . ./$as_me.lineno # Exit status is that of the last command. exit } case `echo "testing\c"; echo 1,2,3`,`echo -n testing; echo 1,2,3` in *c*,-n*) ECHO_N= ECHO_C=' ' ECHO_T=' ' ;; *c*,* ) ECHO_N=-n ECHO_C= ECHO_T= ;; *) ECHO_N= ECHO_C='\c' ECHO_T= ;; esac if expr a : '\(a\)' >/dev/null 2>&1; then as_expr=expr else as_expr=false fi rm -f conf$$ conf$$.exe conf$$.file echo >conf$$.file if ln -s conf$$.file conf$$ 2>/dev/null; then # We could just check for DJGPP; but this test a) works b) is more generic # and c) will remain valid once DJGPP supports symlinks (DJGPP 2.04). if test -f conf$$.exe; then # Don't use ln at all; we don't have any links as_ln_s='cp -p' else as_ln_s='ln -s' fi elif ln conf$$.file conf$$ 2>/dev/null; then as_ln_s=ln else as_ln_s='cp -p' fi rm -f conf$$ conf$$.exe conf$$.file if mkdir -p . 2>/dev/null; then as_mkdir_p=: else test -d ./-p && rmdir ./-p as_mkdir_p=false fi as_executable_p="test -f" # Sed expression to map a string onto a valid CPP name. as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" # Sed expression to map a string onto a valid variable name. as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" # IFS # We need space, tab and new line, in precisely that order. as_nl=' ' IFS=" $as_nl" # CDPATH. $as_unset CDPATH exec 6>&1 # Open the log real soon, to keep \$[0] and so on meaningful, and to # report actual input values of CONFIG_FILES etc. instead of their # values after options handling. Logging --version etc. is OK. exec 5>>config.log { echo sed 'h;s/./-/g;s/^.../## /;s/...$/ ##/;p;x;p;x' <<_ASBOX ## Running $as_me. ## _ASBOX } >&5 cat >&5 <<_CSEOF This file was extended by tclx $as_me 8.4, which was generated by GNU Autoconf 2.59. Invocation command line was CONFIG_FILES = $CONFIG_FILES CONFIG_HEADERS = $CONFIG_HEADERS CONFIG_LINKS = $CONFIG_LINKS CONFIG_COMMANDS = $CONFIG_COMMANDS $ $0 $@ _CSEOF echo "on `(hostname || uname -n) 2>/dev/null | sed 1q`" >&5 echo >&5 _ACEOF # Files that config.status was made for. if test -n "$ac_config_files"; then echo "config_files=\"$ac_config_files\"" >>$CONFIG_STATUS fi if test -n "$ac_config_headers"; then echo "config_headers=\"$ac_config_headers\"" >>$CONFIG_STATUS fi if test -n "$ac_config_links"; then echo "config_links=\"$ac_config_links\"" >>$CONFIG_STATUS fi if test -n "$ac_config_commands"; then echo "config_commands=\"$ac_config_commands\"" >>$CONFIG_STATUS fi cat >>$CONFIG_STATUS <<\_ACEOF ac_cs_usage="\ \`$as_me' instantiates files from templates according to the current configuration. Usage: $0 [OPTIONS] [FILE]... -h, --help print this help, then exit -V, --version print version number, then exit -q, --quiet do not print progress messages -d, --debug don't remove temporary files --recheck update $as_me by reconfiguring in the same conditions --file=FILE[:TEMPLATE] instantiate the configuration file FILE Configuration files: $config_files Report bugs to ." _ACEOF cat >>$CONFIG_STATUS <<_ACEOF ac_cs_version="\\ tclx config.status 8.4 configured by $0, generated by GNU Autoconf 2.59, with options \\"`echo "$ac_configure_args" | sed 's/[\\""\`\$]/\\\\&/g'`\\" Copyright (C) 2003 Free Software Foundation, Inc. This config.status script is free software; the Free Software Foundation gives unlimited permission to copy, distribute and modify it." srcdir=$srcdir INSTALL="$INSTALL" _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF # If no file are specified by the user, then we need to provide default # value. By we need to know if files were specified by the user. ac_need_defaults=: while test $# != 0 do case $1 in --*=*) ac_option=`expr "x$1" : 'x\([^=]*\)='` ac_optarg=`expr "x$1" : 'x[^=]*=\(.*\)'` ac_shift=: ;; -*) ac_option=$1 ac_optarg=$2 ac_shift=shift ;; *) # This is not an option, so the user has probably given explicit # arguments. ac_option=$1 ac_need_defaults=false;; esac case $ac_option in # Handling of the options. _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF -recheck | --recheck | --rechec | --reche | --rech | --rec | --re | --r) ac_cs_recheck=: ;; --version | --vers* | -V ) echo "$ac_cs_version"; exit 0 ;; --he | --h) # Conflict between --help and --header { { echo "$as_me:$LINENO: error: ambiguous option: $1 Try \`$0 --help' for more information." >&5 echo "$as_me: error: ambiguous option: $1 Try \`$0 --help' for more information." >&2;} { (exit 1); exit 1; }; };; --help | --hel | -h ) echo "$ac_cs_usage"; exit 0 ;; --debug | --d* | -d ) debug=: ;; --file | --fil | --fi | --f ) $ac_shift CONFIG_FILES="$CONFIG_FILES $ac_optarg" ac_need_defaults=false;; --header | --heade | --head | --hea ) $ac_shift CONFIG_HEADERS="$CONFIG_HEADERS $ac_optarg" ac_need_defaults=false;; -q | -quiet | --quiet | --quie | --qui | --qu | --q \ | -silent | --silent | --silen | --sile | --sil | --si | --s) ac_cs_silent=: ;; # This is an error. -*) { { echo "$as_me:$LINENO: error: unrecognized option: $1 Try \`$0 --help' for more information." >&5 echo "$as_me: error: unrecognized option: $1 Try \`$0 --help' for more information." >&2;} { (exit 1); exit 1; }; } ;; *) ac_config_targets="$ac_config_targets $1" ;; esac shift done ac_configure_extra_args= if $ac_cs_silent; then exec 6>/dev/null ac_configure_extra_args="$ac_configure_extra_args --silent" fi _ACEOF cat >>$CONFIG_STATUS <<_ACEOF if \$ac_cs_recheck; then echo "running $SHELL $0 " $ac_configure_args \$ac_configure_extra_args " --no-create --no-recursion" >&6 exec $SHELL $0 $ac_configure_args \$ac_configure_extra_args --no-create --no-recursion fi _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF for ac_config_target in $ac_config_targets do case "$ac_config_target" in # Handling of arguments. "Makefile" ) CONFIG_FILES="$CONFIG_FILES Makefile" ;; *) { { echo "$as_me:$LINENO: error: invalid argument: $ac_config_target" >&5 echo "$as_me: error: invalid argument: $ac_config_target" >&2;} { (exit 1); exit 1; }; };; esac done # If the user did not use the arguments to specify the items to instantiate, # then the envvar interface is used. Set only those that are not. # We use the long form for the default assignment because of an extremely # bizarre bug on SunOS 4.1.3. if $ac_need_defaults; then test "${CONFIG_FILES+set}" = set || CONFIG_FILES=$config_files fi # Have a temporary directory for convenience. Make it in the build tree # simply because there is no reason to put it here, and in addition, # creating and moving files from /tmp can sometimes cause problems. # Create a temporary directory, and hook for its removal unless debugging. $debug || { trap 'exit_status=$?; rm -rf $tmp && exit $exit_status' 0 trap '{ (exit 1); exit 1; }' 1 2 13 15 } # Create a (secure) tmp directory for tmp files. { tmp=`(umask 077 && mktemp -d -q "./confstatXXXXXX") 2>/dev/null` && test -n "$tmp" && test -d "$tmp" } || { tmp=./confstat$$-$RANDOM (umask 077 && mkdir $tmp) } || { echo "$me: cannot create a temporary directory in ." >&2 { (exit 1); exit 1; } } _ACEOF cat >>$CONFIG_STATUS <<_ACEOF # # CONFIG_FILES section. # # No need to generate the scripts if there are no CONFIG_FILES. # This happens for instance when ./config.status config.h if test -n "\$CONFIG_FILES"; then # Protect against being on the right side of a sed subst in config.status. sed 's/,@/@@/; s/@,/@@/; s/,;t t\$/@;t t/; /@;t t\$/s/[\\\\&,]/\\\\&/g; s/@@/,@/; s/@@/@,/; s/@;t t\$/,;t t/' >\$tmp/subs.sed <<\\CEOF s,@SHELL@,$SHELL,;t t s,@PATH_SEPARATOR@,$PATH_SEPARATOR,;t t s,@PACKAGE_NAME@,$PACKAGE_NAME,;t t s,@PACKAGE_TARNAME@,$PACKAGE_TARNAME,;t t s,@PACKAGE_VERSION@,$PACKAGE_VERSION,;t t s,@PACKAGE_STRING@,$PACKAGE_STRING,;t t s,@PACKAGE_BUGREPORT@,$PACKAGE_BUGREPORT,;t t s,@exec_prefix@,$exec_prefix,;t t s,@prefix@,$prefix,;t t s,@program_transform_name@,$program_transform_name,;t t s,@bindir@,$bindir,;t t s,@sbindir@,$sbindir,;t t s,@libexecdir@,$libexecdir,;t t s,@datadir@,$datadir,;t t s,@sysconfdir@,$sysconfdir,;t t s,@sharedstatedir@,$sharedstatedir,;t t s,@localstatedir@,$localstatedir,;t t s,@libdir@,$libdir,;t t s,@includedir@,$includedir,;t t s,@oldincludedir@,$oldincludedir,;t t s,@infodir@,$infodir,;t t s,@mandir@,$mandir,;t t s,@build_alias@,$build_alias,;t t s,@host_alias@,$host_alias,;t t s,@target_alias@,$target_alias,;t t s,@DEFS@,$DEFS,;t t s,@ECHO_C@,$ECHO_C,;t t s,@ECHO_N@,$ECHO_N,;t t s,@ECHO_T@,$ECHO_T,;t t s,@LIBS@,$LIBS,;t t s,@CYGPATH@,$CYGPATH,;t t s,@EXEEXT@,$EXEEXT,;t t s,@PKG_LIB_FILE@,$PKG_LIB_FILE,;t t s,@PKG_STUB_LIB_FILE@,$PKG_STUB_LIB_FILE,;t t s,@PKG_STUB_SOURCES@,$PKG_STUB_SOURCES,;t t s,@PKG_STUB_OBJECTS@,$PKG_STUB_OBJECTS,;t t s,@PKG_TCL_SOURCES@,$PKG_TCL_SOURCES,;t t s,@PKG_HEADERS@,$PKG_HEADERS,;t t s,@PKG_INCLUDES@,$PKG_INCLUDES,;t t s,@PKG_LIBS@,$PKG_LIBS,;t t s,@PKG_CFLAGS@,$PKG_CFLAGS,;t t s,@TCL_VERSION@,$TCL_VERSION,;t t s,@TCL_BIN_DIR@,$TCL_BIN_DIR,;t t s,@TCL_SRC_DIR@,$TCL_SRC_DIR,;t t s,@TCL_LIB_FILE@,$TCL_LIB_FILE,;t t s,@TCL_LIB_FLAG@,$TCL_LIB_FLAG,;t t s,@TCL_LIB_SPEC@,$TCL_LIB_SPEC,;t t s,@TCL_STUB_LIB_FILE@,$TCL_STUB_LIB_FILE,;t t s,@TCL_STUB_LIB_FLAG@,$TCL_STUB_LIB_FLAG,;t t s,@TCL_STUB_LIB_SPEC@,$TCL_STUB_LIB_SPEC,;t t s,@TCL_LIBS@,$TCL_LIBS,;t t s,@TCL_DEFS@,$TCL_DEFS,;t t s,@TCL_EXTRA_CFLAGS@,$TCL_EXTRA_CFLAGS,;t t s,@TCL_LD_FLAGS@,$TCL_LD_FLAGS,;t t s,@TCL_SHLIB_LD_LIBS@,$TCL_SHLIB_LD_LIBS,;t t s,@CC@,$CC,;t t s,@CFLAGS@,$CFLAGS,;t t s,@LDFLAGS@,$LDFLAGS,;t t s,@CPPFLAGS@,$CPPFLAGS,;t t s,@ac_ct_CC@,$ac_ct_CC,;t t s,@OBJEXT@,$OBJEXT,;t t s,@CPP@,$CPP,;t t s,@INSTALL_PROGRAM@,$INSTALL_PROGRAM,;t t s,@INSTALL_SCRIPT@,$INSTALL_SCRIPT,;t t s,@INSTALL_DATA@,$INSTALL_DATA,;t t s,@SET_MAKE@,$SET_MAKE,;t t s,@RANLIB@,$RANLIB,;t t s,@ac_ct_RANLIB@,$ac_ct_RANLIB,;t t s,@EGREP@,$EGREP,;t t s,@MATH_LIBS@,$MATH_LIBS,;t t s,@PKG_SOURCES@,$PKG_SOURCES,;t t s,@PKG_OBJECTS@,$PKG_OBJECTS,;t t s,@TCL_TOP_DIR_NATIVE@,$TCL_TOP_DIR_NATIVE,;t t s,@TCL_GENERIC_DIR_NATIVE@,$TCL_GENERIC_DIR_NATIVE,;t t s,@TCL_UNIX_DIR_NATIVE@,$TCL_UNIX_DIR_NATIVE,;t t s,@TCL_WIN_DIR_NATIVE@,$TCL_WIN_DIR_NATIVE,;t t s,@TCL_BMAP_DIR_NATIVE@,$TCL_BMAP_DIR_NATIVE,;t t s,@TCL_TOOL_DIR_NATIVE@,$TCL_TOOL_DIR_NATIVE,;t t s,@TCL_PLATFORM_DIR_NATIVE@,$TCL_PLATFORM_DIR_NATIVE,;t t s,@TCL_INCLUDES@,$TCL_INCLUDES,;t t s,@CLEANFILES@,$CLEANFILES,;t t s,@TCL_THREADS@,$TCL_THREADS,;t t s,@SHARED_BUILD@,$SHARED_BUILD,;t t s,@AR@,$AR,;t t s,@CELIB_DIR@,$CELIB_DIR,;t t s,@LIBOBJS@,$LIBOBJS,;t t s,@DL_LIBS@,$DL_LIBS,;t t s,@CFLAGS_DEBUG@,$CFLAGS_DEBUG,;t t s,@CFLAGS_OPTIMIZE@,$CFLAGS_OPTIMIZE,;t t s,@CFLAGS_WARNING@,$CFLAGS_WARNING,;t t s,@STLIB_LD@,$STLIB_LD,;t t s,@SHLIB_LD@,$SHLIB_LD,;t t s,@SHLIB_LD_LIBS@,$SHLIB_LD_LIBS,;t t s,@SHLIB_CFLAGS@,$SHLIB_CFLAGS,;t t s,@LD_LIBRARY_PATH_VAR@,$LD_LIBRARY_PATH_VAR,;t t s,@TCL_DBGX@,$TCL_DBGX,;t t s,@CFLAGS_DEFAULT@,$CFLAGS_DEFAULT,;t t s,@LDFLAGS_DEFAULT@,$LDFLAGS_DEFAULT,;t t s,@NROFF@,$NROFF,;t t s,@COL@,$COL,;t t s,@BUILDHELP@,$BUILDHELP,;t t s,@HELP_DIR@,$HELP_DIR,;t t s,@MAKE_LIB@,$MAKE_LIB,;t t s,@MAKE_SHARED_LIB@,$MAKE_SHARED_LIB,;t t s,@MAKE_STATIC_LIB@,$MAKE_STATIC_LIB,;t t s,@MAKE_STUB_LIB@,$MAKE_STUB_LIB,;t t s,@RANLIB_STUB@,$RANLIB_STUB,;t t s,@TCLSH_PROG@,$TCLSH_PROG,;t t CEOF _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF # Split the substitutions into bite-sized pieces for seds with # small command number limits, like on Digital OSF/1 and HP-UX. ac_max_sed_lines=48 ac_sed_frag=1 # Number of current file. ac_beg=1 # First line for current file. ac_end=$ac_max_sed_lines # Line after last line for current file. ac_more_lines=: ac_sed_cmds= while $ac_more_lines; do if test $ac_beg -gt 1; then sed "1,${ac_beg}d; ${ac_end}q" $tmp/subs.sed >$tmp/subs.frag else sed "${ac_end}q" $tmp/subs.sed >$tmp/subs.frag fi if test ! -s $tmp/subs.frag; then ac_more_lines=false else # The purpose of the label and of the branching condition is to # speed up the sed processing (if there are no `@' at all, there # is no need to browse any of the substitutions). # These are the two extra sed commands mentioned above. (echo ':t /@[a-zA-Z_][a-zA-Z_0-9]*@/!b' && cat $tmp/subs.frag) >$tmp/subs-$ac_sed_frag.sed if test -z "$ac_sed_cmds"; then ac_sed_cmds="sed -f $tmp/subs-$ac_sed_frag.sed" else ac_sed_cmds="$ac_sed_cmds | sed -f $tmp/subs-$ac_sed_frag.sed" fi ac_sed_frag=`expr $ac_sed_frag + 1` ac_beg=$ac_end ac_end=`expr $ac_end + $ac_max_sed_lines` fi done if test -z "$ac_sed_cmds"; then ac_sed_cmds=cat fi fi # test -n "$CONFIG_FILES" _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF for ac_file in : $CONFIG_FILES; do test "x$ac_file" = x: && continue # Support "outfile[:infile[:infile...]]", defaulting infile="outfile.in". case $ac_file in - | *:- | *:-:* ) # input from stdin cat >$tmp/stdin ac_file_in=`echo "$ac_file" | sed 's,[^:]*:,,'` ac_file=`echo "$ac_file" | sed 's,:.*,,'` ;; *:* ) ac_file_in=`echo "$ac_file" | sed 's,[^:]*:,,'` ac_file=`echo "$ac_file" | sed 's,:.*,,'` ;; * ) ac_file_in=$ac_file.in ;; esac # Compute @srcdir@, @top_srcdir@, and @INSTALL@ for subdirectories. ac_dir=`(dirname "$ac_file") 2>/dev/null || $as_expr X"$ac_file" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$ac_file" : 'X\(//\)[^/]' \| \ X"$ac_file" : 'X\(//\)$' \| \ X"$ac_file" : 'X\(/\)' \| \ . : '\(.\)' 2>/dev/null || echo X"$ac_file" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/; q; } /^X\(\/\/\)[^/].*/{ s//\1/; q; } /^X\(\/\/\)$/{ s//\1/; q; } /^X\(\/\).*/{ s//\1/; q; } s/.*/./; q'` { if $as_mkdir_p; then mkdir -p "$ac_dir" else as_dir="$ac_dir" as_dirs= while test ! -d "$as_dir"; do as_dirs="$as_dir $as_dirs" as_dir=`(dirname "$as_dir") 2>/dev/null || $as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$as_dir" : 'X\(//\)[^/]' \| \ X"$as_dir" : 'X\(//\)$' \| \ X"$as_dir" : 'X\(/\)' \| \ . : '\(.\)' 2>/dev/null || echo X"$as_dir" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/; q; } /^X\(\/\/\)[^/].*/{ s//\1/; q; } /^X\(\/\/\)$/{ s//\1/; q; } /^X\(\/\).*/{ s//\1/; q; } s/.*/./; q'` done test ! -n "$as_dirs" || mkdir $as_dirs fi || { { echo "$as_me:$LINENO: error: cannot create directory \"$ac_dir\"" >&5 echo "$as_me: error: cannot create directory \"$ac_dir\"" >&2;} { (exit 1); exit 1; }; }; } ac_builddir=. if test "$ac_dir" != .; then ac_dir_suffix=/`echo "$ac_dir" | sed 's,^\.[\\/],,'` # A "../" for each directory in $ac_dir_suffix. ac_top_builddir=`echo "$ac_dir_suffix" | sed 's,/[^\\/]*,../,g'` else ac_dir_suffix= ac_top_builddir= fi case $srcdir in .) # No --srcdir option. We are building in place. ac_srcdir=. if test -z "$ac_top_builddir"; then ac_top_srcdir=. else ac_top_srcdir=`echo $ac_top_builddir | sed 's,/$,,'` fi ;; [\\/]* | ?:[\\/]* ) # Absolute path. ac_srcdir=$srcdir$ac_dir_suffix; ac_top_srcdir=$srcdir ;; *) # Relative path. ac_srcdir=$ac_top_builddir$srcdir$ac_dir_suffix ac_top_srcdir=$ac_top_builddir$srcdir ;; esac # Do not use `cd foo && pwd` to compute absolute paths, because # the directories may not exist. case `pwd` in .) ac_abs_builddir="$ac_dir";; *) case "$ac_dir" in .) ac_abs_builddir=`pwd`;; [\\/]* | ?:[\\/]* ) ac_abs_builddir="$ac_dir";; *) ac_abs_builddir=`pwd`/"$ac_dir";; esac;; esac case $ac_abs_builddir in .) ac_abs_top_builddir=${ac_top_builddir}.;; *) case ${ac_top_builddir}. in .) ac_abs_top_builddir=$ac_abs_builddir;; [\\/]* | ?:[\\/]* ) ac_abs_top_builddir=${ac_top_builddir}.;; *) ac_abs_top_builddir=$ac_abs_builddir/${ac_top_builddir}.;; esac;; esac case $ac_abs_builddir in .) ac_abs_srcdir=$ac_srcdir;; *) case $ac_srcdir in .) ac_abs_srcdir=$ac_abs_builddir;; [\\/]* | ?:[\\/]* ) ac_abs_srcdir=$ac_srcdir;; *) ac_abs_srcdir=$ac_abs_builddir/$ac_srcdir;; esac;; esac case $ac_abs_builddir in .) ac_abs_top_srcdir=$ac_top_srcdir;; *) case $ac_top_srcdir in .) ac_abs_top_srcdir=$ac_abs_builddir;; [\\/]* | ?:[\\/]* ) ac_abs_top_srcdir=$ac_top_srcdir;; *) ac_abs_top_srcdir=$ac_abs_builddir/$ac_top_srcdir;; esac;; esac case $INSTALL in [\\/$]* | ?:[\\/]* ) ac_INSTALL=$INSTALL ;; *) ac_INSTALL=$ac_top_builddir$INSTALL ;; esac if test x"$ac_file" != x-; then { echo "$as_me:$LINENO: creating $ac_file" >&5 echo "$as_me: creating $ac_file" >&6;} rm -f "$ac_file" fi # Let's still pretend it is `configure' which instantiates (i.e., don't # use $as_me), people would be surprised to read: # /* config.h. Generated by config.status. */ if test x"$ac_file" = x-; then configure_input= else configure_input="$ac_file. " fi configure_input=$configure_input"Generated from `echo $ac_file_in | sed 's,.*/,,'` by configure." # First look for the input files in the build tree, otherwise in the # src tree. ac_file_inputs=`IFS=: for f in $ac_file_in; do case $f in -) echo $tmp/stdin ;; [\\/$]*) # Absolute (can't be DOS-style, as IFS=:) test -f "$f" || { { echo "$as_me:$LINENO: error: cannot find input file: $f" >&5 echo "$as_me: error: cannot find input file: $f" >&2;} { (exit 1); exit 1; }; } echo "$f";; *) # Relative if test -f "$f"; then # Build tree echo "$f" elif test -f "$srcdir/$f"; then # Source tree echo "$srcdir/$f" else # /dev/null tree { { echo "$as_me:$LINENO: error: cannot find input file: $f" >&5 echo "$as_me: error: cannot find input file: $f" >&2;} { (exit 1); exit 1; }; } fi;; esac done` || { (exit 1); exit 1; } _ACEOF cat >>$CONFIG_STATUS <<_ACEOF sed "$ac_vpsub $extrasub _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF :t /@[a-zA-Z_][a-zA-Z_0-9]*@/!b s,@configure_input@,$configure_input,;t t s,@srcdir@,$ac_srcdir,;t t s,@abs_srcdir@,$ac_abs_srcdir,;t t s,@top_srcdir@,$ac_top_srcdir,;t t s,@abs_top_srcdir@,$ac_abs_top_srcdir,;t t s,@builddir@,$ac_builddir,;t t s,@abs_builddir@,$ac_abs_builddir,;t t s,@top_builddir@,$ac_top_builddir,;t t s,@abs_top_builddir@,$ac_abs_top_builddir,;t t s,@INSTALL@,$ac_INSTALL,;t t " $ac_file_inputs | (eval "$ac_sed_cmds") >$tmp/out rm -f $tmp/stdin if test x"$ac_file" != x-; then mv $tmp/out $ac_file else cat $tmp/out rm -f $tmp/out fi done _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF { (exit 0); exit 0; } _ACEOF chmod +x $CONFIG_STATUS ac_clean_files=$ac_clean_files_save # configure is writing to config.log, and then calls config.status. # config.status does its own redirection, appending to config.log. # Unfortunately, on DOS this fails, as config.log is still kept open # by configure, so config.status won't be able to write to it; its # output is simply discarded. So we exec the FD to /dev/null, # effectively closing config.log, so it can be properly (re)opened and # appended to by config.status. When coming back to configure, we # need to make the FD available again. if test "$no_create" != yes; then ac_cs_success=: ac_config_status_args= test "$silent" = yes && ac_config_status_args="$ac_config_status_args --quiet" exec 5>/dev/null $SHELL $CONFIG_STATUS $ac_config_status_args || ac_cs_success=false exec 5>>config.log # Use ||, not &&, to avoid exiting from the if with $? = 1, which # would make configure fail if this is the last instruction. $ac_cs_success || { (exit 1); exit 1; } fi tclx8.4-8.4.1.orig/doc/0000755000000000000000000000000012046525461011327 5ustar tclx8.4-8.4.1.orig/doc/ObjCmdWrite.30000644000000000000000000014263212046313167013572 0ustar .\" .\" ObjCmdWrite.3 .\" .\" Command writing manual. .\"---------------------------------------------------------------------------- .\" Copyright 1992-1999 Karl Lehenbauer and Mark Diekhans. .\" .\" Permission to use, copy, modify, and distribute this software and its .\" documentation for any purpose and without fee is hereby granted, provided .\" that the above copyright notice appear in all copies. Karl Lehenbauer and .\" Mark Diekhans make no representations about the suitability of this .\" software for any purpose. It is provided "as is" without express or .\" implied warranty. .\"---------------------------------------------------------------------------- .\" $Id: ObjCmdWrite.3,v 8.4 1999/03/31 06:37:42 markd Exp $ .\"---------------------------------------------------------------------------- .\" .TH "Command Writing" TCL "" "Tcl" .ad b .SH NAME TclCommandWriting - Writing C language extensions to Tcl. ' .SH OVERVIEW This document is intended to help the programmer who wishes to extend Tcl with C language routines. It should also be useful to someone wishing to add Tcl to an existing editor, communications program, window manager, etc. Experienced extension writers may find this manual helpful in rewriting their applications to use the new Tcl object system. We assume you are already fluent in the C programming language and that you have built and installed Tcl on your machine. .PP Information on the available C interface routines to Tcl can be found in the \fI*.3\fR manual pages in the \fIdoc\fR directory of the baseline Tcl distribution, and in the \fI*.3\fR manpages in the \fIdoc\fR directory of Extended Tcl. ' .SH TCL OBJECT SYSTEM ' With the release of Tcl version 8, Tcl has a new system for managing Tcl values internally. To the Tcl programmer, the new objects look and act like strings, as before. But at the C level, these objects can now also hold cached internal representations of the strings in various native datatypes. For example, an object containing a string consisting of an integer, will now maintain a machine-code integer representation, if an integer representation has been needed. Using these objects is much more efficient than using the older-style Tcl strings, although the older style is still (currently) supported. .PP Although the object system has almost no effect at all on how the Tcl programmer uses Tcl, the object system's C interfaces to strings, integers, lists, etc., have changed considerably. While converting a package to use the new system can be a lot of work, the combination of the object system, which saves Tcl from having to constantly convert strings to integers and back, etc., and the on-the-fly bytecode compiler (which keeps Tcl from having to continually reparse code it is to execute) yield Tcl programs that routinely execute several times more quickly than with previous versions (Tcl 7 and before), and in some cases run as much as 2500 (!) times faster than before. .PP We have chosen, then, to rewrite the Command Writer's manpage, which has been shipping with Extended Tcl for a number of years, to produce this new version based on the new object system. The old manpage, based on the older string-oriented routines, will still be included in TclX releases for now, as it is still relevant to Tcl releases through version 7, and may be of use to those modifying/upgrading packages written for the old model. The old manual will be dropped from the release once we deem it unneeded; the old interfaces should now be considered legacy interfaces, and all new development should be done using the new object interfaces, unless backwards compatibility to pre-Tcl-8 releases is needed. .SH A SIMPLE C EXTENSION All C-based Tcl commands are called with four arguments: a client data pointer, an interpreter pointer, an argument count and a pointer to an array of Tcl objects containing the arguments to the command. .PP A simple C extension to Tcl is now presented, and described below: .sp .nf .ft CW #include "tcl.h" int App_DumpArgsObjCmd(clientData, interp, objc, objv) void *clientData; Tcl_Interp *interp; int objc; Tcl_Obj **objv; { int i; int stringLen; char *stringPtr; for (i = 1; i < objc; i++) { stringPtr = Tcl_GetStringFromObj (objv [i], &stringLen); printf("%s", stringPtr); if (i < objc - 1) printf(" "); } printf("\\n"); return TCL_OK; } .ft R .fi .PP The client data pointer will be described later. .SH INTERPRETERS The interpreter pointer is the ``key'' to an interpreter. It is returned by \fBTcl_CreateInterp\fR and is used extensively within Tcl, and will be used by your C extensions. The data structure pointed to by the interpreter pointer, and all of the subordinate structures that branch off of it, make up a Tcl interpreter, which includes all of the currently defined procedures, commands, variables, arrays and the execution state of that interpreter. (For more information on creating and deleting interpreters, please examine the \fBCrtInterp\fR(3) manpage in the core Tcl distribution. For information on creating interpreters that include the commands provided by Extended Tcl, check out the \fBTclX_Init\fR(3) manpage of Extended Tcl. For a manual page describing the user-visible fields of a Tcl interpreter, please look at \fBInterp\fR(3) in core Tcl.) .SH OBJECT COUNT AND ARGUMENTS The argument count, or object count (objc), and pointer to an array of pointers to Tcl objects of the command's arguments (objv) is handled by your C code, in a manner similar to the one you would use in writing a C \fImain\fR function -- an argument count and array of pointers works the same as in a C \fImain\fR call; pointers to the arguments to the function are contained in the \fIobjv\fR array. Similar to a C main, the first argument (\fIobjv[0]\fR) is an object containing the name the routine was called as (in a C main, the name the program was invoked as). .PP In Tcl, however, the array of pointers are not pointers to character strings (although they were in all version of Tcl before 8.0). .PP In the above example, all of the arguments are output with a space between each one by looping through elements of the \fIobjv\fR array from one to the argument count, \fIobjc\fR, and a newline is output to terminate the line -- a simple ``echo'' command. This example uses printf for simplicity. Of course in production code you would want to use the Tcl filesystem interfaces. See \fBGetFile\fR(3) and friends for more information. .PP All arguments from a Tcl call to a Tcl C extension are passed as Tcl Objects. If your C routine wants to look at one of those arguments as an integer, you need to make a call to a routine to fetch the representation of the object that you need. In the earlier example, for instance, \fBTcl_GetStringFromObj\fR is called to obtain a textual representation of an object. Additional routines are available to fetch the representation of a data element as other data types. Tcl_GetBooleanFromObj, Tcl_GetDoubleFromObj, Tcl_GetIntFromObj, Tcl_GetLongFromObj, and Tcl_GetIndexFromObj, fetch object representations of Tcl strings as booleans, double-precision floating point, integer, long integer, and lists, among others. .PP These routines automatically leave an appropriate error message in the Tcl interpreter's result object and return \fBTCL_ERROR\fR if a conversion error occurs. (For more information on these routines, please look at the \fBObject\fR(3) manpage in the core Tcl distribution.) ' .SH RETURNING RESULTS ' As you might expect, the API for setting results from C extensions has changed significantly under the object system. The old technique of writing small results directory into the interpreter's result buffer is no longer used, for example. The notion of having to tell Tcl whether a result is static or dynamic is also a thing of the past. Under the object system, results are objects that are set up by your code, and objects are freed when their reference counts say they should be. More on this later. .P If you program produces a numeric result, it should set the result object to contain that numeric value. A common way of doing this is something like... .sp .nf .ft CW Tcl_Obj *obj; obj = Tcl_GetObjResult (interp); Tcl_SetIntObj (obj, value); .ft R .fi .PP The above code obtains a pointer to the result object (an object made available to your routine that you're supposed to store your results into) and sets the integer value \fIvalue\fR into it. .PP Another way to do it would be to set up a new object and tell Tcl that this object contains the result... .sp .nf .ft CW Tcl_Obj *resultObj; /* create a new object for use as a result */ resultObj = Tcl_NewObj (); Tcl_SetIntObj (obj, value); Tcl_SetObjResult (interp, resultObj); .ft R .fi .PP Understanding how results are passed back to Tcl is essential to the C extension writer. Please study the \fBSetObjResult\fR(3) manual page in the Tcl distribution for more information. ' .SH VALIDATING ARGUMENTS ' It is a design goal of Tcl that no Tcl program be able to cause Tcl to dump core. It is important that the extension writers, likewise, use the avaiable methods and tools to make sure that their extensions do not allow unchecked input, for example, to cause the code to get some kind of runtime exception. .PP The object system has simplified, to some degree, the task of validating arguments, in that the object system automatically attempts type conversions as needed, and will return an error when a type conversion fails. .PP A simple, but important, check that every C extension should do is verify that it has the right number of arguments. .PP The act of trying to use, say, a string as an integer, implicitly performs the type conversion of the string and, if it doesn't work as an integer, returns TCL_ERROR. The developer should check for the TCL_ERROR return from all of the GetXxxFromObj commands, and handle them as appropriate. Usually this will mean propagating the error on back to the user, or to an intevening catch, as the case may be. .PP You should also check that values are in range (when their ranges are known), and so forth. When C data structures need to be handled in Tcl in some form or another, yet the contents of the data must remain opaque to Tcl, as is usually the case with binary data (although futures releases of Tcl are expected to have native abilities to read, write and manipulate binary data instrinsically), \fIhandles\fR need to be used. Handles will be described and examples presented, later in this doc. ' .SH ANOTHER C EXTENSION - THE MAX COMMAND ' In the command below, two or more arguments are compared, and the one with the maximum value is returned, if all goes well. It is an error if there are fewer than two arguments (the pointer to the ``max'' command text itself, \fIobjv[0]\fR, and a pointer to at least one object to compare the values of). .PP .nf .ft CW int Tcl_MaxCmd (clientData, interp, objc, objv) char *clientData; Tcl_Interp *interp; int objc; Tcl_Obj **objv; { int maxVal = MININT; int value, idx; if (objc < 3) return TclX_WrongArgs (interp, objv[0], " num1 num2 [..numN]"); for (idx = 1; idx < objc; idx++) { if (Tcl_GetIntFromObj (interp, objv[idx], &value) != TCL_OK) return TCL_ERROR; if (value > maxVal) { maxVal = value; } } Tcl_SetIntObj (Tcl_GetObjResult (interp), value); return TCL_OK; } .ft R .fi .PP Here we introduce the Extended Tcl helper function \fBTclX_WrongArgs\fR. This routine makes it easy to create an error message and error return in response to the common mistake of being called with a wrong number. .PP \fBTcl_GetIntFromObj\fR is used to fetch the integer values of the remaining arguments. If any fail to be converted, we return a Tcl error. If an interpreter is specified in the call to \fBTcl_GetIntFromObj\fR, an appropriate error message about the conversion failure will be left in the result, so we do that here. .PP After examining all of the arguments to find the largest value, we set the result object to contain that value, and return \fBTCL_OK\fR. ' .SH RETURNING RESULTS ' When Tcl-callable functions complete, they should normally return \fBTCL_OK\fR or \fBTCL_ERROR\fR. \fBTCL_OK\fR is returned when the command succeeded, and \fBTCL_ERROR\fR is returned when the command has failed in some abnormal way. \fBTCL_ERROR\fR should be returned for all syntax errors, non-numeric values when numeric ones were expected, and so forth. Less clear in some cases is whether Tcl errors should be returned or whether a function should just return a status value. For example, end-of-file during a \fIgets\fR returns a status, but \fIopen\fR returns an error if it fails. Errors can be caught from Tcl programs using the \fIcatch\fR command. (See Tcl's \fBcatch\fR(n) and \fBerror\fR(n) manual pages.) .PP Less common return values are \fBTCL_RETURN\fR, \fBTCL_BREAK\fR and \fBTCL_CONTINUE\fR. These are used if you are adding new control and/or looping structures to Tcl. To see these values in action, examine the source code to Extended Tcl's \fIloop\fR commands. Tcl's \fIwhile\fR, \fIfor\fR and \fIif\fR commands used to work in the just same manner, but are now compiled into bytecode by the bytecode for performance. .PP .SH ANOTHER C EXTENSION - THE LREVERSE COMMAND In the command below, a list is passed as an argument, and a list containing all of the elements of the list in reverse order is returned. It is an error if anything other than two arguments are passed (the pointer to the ``lreverse'' command text itself, \fIobjv[0]\fR, and a pointer to the list to reverse. .PP Once \fIlreverse\fR has determined that it has received the correct number of arguments, \fBTcl_ListObjGetElements\fR is called to split the list into its own \fIobjc\fR count of elements and \fIobjv\fR array of pointers to the list's elements. .PP \fIlreverse\fR then operates on the array of pointers, swapping them from lowest to highest, second-lowest to second-highest, and so forth. .PP \fBTcl_ListObjAppendElement\fR is called on successive list elements to build up the new list, which is finally returned as result of the command. .PP .sp .nf .ft CW int Tcl_LreverseObjCmd(notUsed, interp, objc, objv) ClientData notUsed; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj **obj; /* Argument strings. */ { int listObjc, lowListIndex, hiListIndex; Tcl_Obj **listObjv; char *temp, *resultList; Tcl_Obj **newListObjv; /* Verify argument count. Since we take only one argument, argument * count must be 2 (command plus one argument). */ if (objc != 2) return TclX_WrongArgs (interp, objv [0], "list"); /* Create an object to handle the new list we're creating */ newListObjv = Tcl_NewObj(); /* Crack the list at objv[1] into its own count and array of object * pointers. */ if (Tcl_ListObjGetElements (interp, objv[1], &listObjc, &listObjv) != TCL_OK) { return TCL_ERROR; } /* For each element in the source list from last to first, append an * element to the new list. */ for (listIndex = listObjc - 1; listIndex >= 0; listIndex--) { Tcl_ListObjAppendElement (interp, newListObjv, listObjv[listIndex]); } FIX: NEED TO RETURN THE LIST. return TCL_OK; } .ft R .fi .PP ' .SH INSTALLING YOUR COMMAND .P To install your command into Tcl you must call \fBTcl_CreateObjCommand\fR, passing it the pointer to the interpreter you want to install the command into, the name of the command, a pointer to the C function that implements the command, a client data pointer, and a pointer to an optional callback routine. .PP The client data pointer and the callback routine will be described later. .PP For example, for the max function above (which, incidentally, comes from TclX's tclXmath.c in the \fITclX7.4/src\fR directory): .sp .nf .ft CW Tcl_CreateCommand (interp, "max", Tcl_MaxCmd, (ClientData)NULL, (void (*)())NULL); .ft R .fi .PP In the above example, the max function is added to the specified interpreter. The client data pointer and callback function pointer are NULL. (For complete information on \fBTcl_CreateCommand\fR and its companion routine, \fBTcl_CommandInfo\fR, please examine the \fBCrtCommand\fR(3) command page in the core Tcl distribution.) .PP .SH DYNAMIC STRINGS .PP \fIDynamic strings\fR are an important abstraction that first became available with Tcl 7.0. Dynamic strings, or \fIDStrings\fR, provide a way to build up arbitrarily long strings through a repeated process of appending information to them. DStrings reduce the amount of allocating and copying required to add information to a string. Further, they simplify the process of doing so. .PP At first glance, it may seem that the object system supersedes DStrings. It does not, in that the performance improvements made possible by the lazy conversion of an object's representation from one datatype to another does not come into play much while constructing strings as the string representation is always available either without any type conversion or where type conversion would be necessary in any case as a string representation of the object is required when strings are being constructed by concatenation, etc. .PP It should be noted, however, that the C level string manipulation capabilites of objects, such as \fBTcl_AppendToObj\fR and \fBTcl_AppendStringsToObj\fR, are often plenty enough for what you need to do. For complete information on dynamic strings, please examine the \fBDString\fR(3) manual page in the core Tcl distribution. For more on Tcl object's string-oriented calls, seek \fBTcl_StringObj\fR(3) in the same location. .PP .SH CLIENT DATA .PP The client data pointer provides a means for Tcl commands to have data associated with them that is not global to the C program nor included in the Tcl core. Client data is essential in a multi-interpreter environment (where a single program has created and is making use of multiple Tcl interpreters) for the C routines to maintain any permanent data they need on a per-interpreter basis. If needed static data was simply declared static in C, you will probably have reentrancy problems when you work with multiple interpreters. .PP Tcl solves this through the client data mechanism. When you are about to call \fBTcl_CreateObjCommand\fR to add a new command to an interpreter, if your command needs to keep some read/write data across invocations, you should allocate the space, preferably using \fBTcl_Alloc\fR instead of \fBmalloc\fR, then pass the address of that space as the ClientData pointer to \fBTcl_CreateObjCommand\fR. .PP When your command is called from Tcl, the ClientData pointer you passed to \fBTcl_CreateObjCommand\fR will be passed to your C routine through the ClientData pointer calling argument. .PP Commands that need to share this data with one another can do so by using the same ClientData pointer when the commands are added. .PP It is important to note that the Tcl extensions in the \fItclX8.0.0\fR directory have had all of their data set up in this way. Since release 6.2, Extended Tcl has supported multiple interpreters within one invocation of Tcl. ' .SH THEORY OF HANDLES Sometimes you need to have a data element that isn't readily representable as a string within Tcl, for example a pointer to a complex C data structure. It is not a good idea to try to pass pointers around within Tcl as strings by converting them to and from hex or integer representations, for example. It is too easy to mess one up, and the likely outcome of doing that is a core dump. .PP Instead we have developed and made use of the concept of \fIhandles\fR. Handles are identifiers a C extension can pass to, and accept from, Tcl to make the transition between what your C code knows something as and what name Tcl knows it by to be as safe and painless as possible. For example, the I/O system included in Tcl uses file handles. When you open a file from Tcl, a handle is returned of the form \fBfile\fIn\fR where \fIn\fR is a file number. When you pass the file handle back to \fIputs\fR, \fIgets\fR, \fIseek\fR, \fIflush\fR and so forth, they validate the file handle by checking the the \fBfile\fR text is present, then converting the file number to an integer that they use to look into a data structure of pointers to Tcl open file structures, which contain a Unix file descriptor, flags indicating whether or not the file is currently open, whether the file is a file or a pipe and so forth. .PP Handles have proven so useful that, since TclX release 6.1a, general support has been available to help create and manipulate them. Many of these capabilities have migrated into baseline Tcl. If you have a similar need, you might like to use the handle routines documented in \fBHandles\fR(3) in Extended Tcl. We recommend that you use a unique-to-your-package textual handle coupled with a specific identifier and let the handle management routines validate it when it's passed back. It is much easier to track down a bug with an implicated handle named something like \fBfile4\fR or \fBbitmap6\fR than just \fB6\fR. .PP Note that Tcl's object offers another way for complex data structures to exist in parallel with and underneath Tcl strings. As of this writing (May 30, 1997) this is fairly new territory, but things are looking good for the prospects of using the Tcl object system in this manner, and for enhancements to the object system that allow even Tcl objects to have methods in a very straightforward and simple way. ' .SH USING COMMANDS TO DO THE SAME THING, AND MORE .PP Another handle-like technique, first popularized in the Tk toolkit, offers handle-like capabilities as well as some neat additional capabilities. That is to create a new Tcl command, from C, that uses ClientData to keep a "handle" on its complex underlying data structure. Then by having that command look at its second argument for what it is to do (its sub-functions), you get these nice methods, where you have several additional sub-commands that don't pollute the global namespace and only work on (and are available with) the objects (new commands) they are relevant to. For example, in Tk, creating a checkbutton (\fBcheckbutton .b\fB) creates a new Tcl command (\fB.b\fB), that has methods to configure the button, select, deselect, toggle and flash it. .PP A lot of people think this is really the way to go, and I am pretty much leaning that way myself. If you use the \fBincr tcl\fR script-level object system for Tcl, objects that you define in Tcl will be highly compatible in terms of their command interfaces and configuration management with objects you create in C using the the command-and-ClientData technique described here. I believe \fBTk\fR has some nice facilities for making this easy for the Tcl programmer. \fBItcl\fR certainly does. .PP .SH TRACKING MEMORY CORRUPTION PROBLEMS Occasionally you may write code that scribbles past the end of an allocated piece of memory. This will usually result in a core dump or memory allocation failure sometime later in the program, often implicating code that is not actually responsible for the problem (as you start looking from the point where the error is detected, which is usually where the later routine has failed). .PP The memory debugging routines included in Tcl can help find these problems. Developed by Mark and Karl, the memory debugging routines are now part of baseline Tcl, and is to our knowledge the largest piece of TclX to drop into the core without being reengineered first. (You see, summer back in '91, John was sitting in his office in the CS building at UC Berkeley trying to find a memory leak somewhere in Tcl, when he was paid a visit by two long-haired-yet-polite programmers bearing gifts in the form of the technology grab-bag known as Extended Tcl. He saw that, using TclX's malloc routines, Tcl could be prompted to print the filename and line number of every single memory allocation that did not have a corresponding free. It was just what the doctor ordered ;-) See \fIMemory(TCL)\fR for details. .PP .SH INSTALLING YOUR EXTENSIONS INTO TCL To add your extensions to Tcl, you used to have to statically link them, together with any other extensions, into a single binary executable image. Today, although the statically linked executable is still an option, most operating systems, even Microsoft Windows, support shared libraries, and in most cases, Tcl can now make use of those shared libraries such that you extensions, and most others, can now be built a shared libraries that can be loaded in (using \fBpackage require\fR) by scripts that need them. Shared libraries can simplify a Tcl installation, because only one copy of Tcl is required, rather than a hodepodge of combinations of applications that you might have found at a big Tcl site in the previous era. ' .SH GNU AUTOCONF While the build procedure for shared libraries varies from system to system, most Unix and Unix workalike systems will figure out the nuances of the compiler and linker arguments automatically when the \fIconfigure\fR script is run. If you are building a package that you plan to make generally available, we strongly recommend that you use \fBGNU autoconf\fR (ftp://prep.ai.mit.edu/pub/gnu) to set up an automatic \fIconfigure\fR script for it. Be forewarned that \fIautoconf\fR uses some pretty heavy duty shell and sed script magic to get the job done, and the learning curve can be pretty steep. Once done and shaken out, though, it's rewarding to know that your package can build and run on everything from a notebook to a Cray to a RISC SMP server. .PP Application-specific startup is accomplished by creating or editing the \fITcl_AppInit\fR function. In \fITcl_AppInit\fR you should add a call to an application-specific init function which you create. This function should take the address of the interpreter it should install its commands into, and it should install those commands with \fBTcl_CreateCommand\fR and do any other application-specific startup that is necessary. .PP The naming convention for application startup routines is \fBApp_Init\fR, where \fIApp\fR is the name of your application. For example, to add an application named \fIcute\fR one would create a \fICute_Init\fR routine that expected a \fBTcl_Interp\fR pointer as an argument, and add the following code to \fITcl_AppInit\fR: .sp .nf .ft CW if (Cute_Init (interp) == TCL_ERROR) { return TCL_ERROR; } .ft R .fi .PP As you can guess from the above example, if your init routine is unable to initialize, it should use \fBTcl_AppendResult\fR to provide some kind of useful error message back to TclX, then return \fBTCL_ERROR\fR to indicate that an error occurred. If the routine executed successfully, it should return \fBTCL_OK\fR. .PP When you examine \fITcl_AppInit\fR, note that there is one call already there to install an application -- the call to \fITclX_Init\fR installs Extended Tcl into the Tcl core. .SH MAKING APPLICATION INFORMATION VISIBLE FROM EXTENDED TCL TclX's \fBinfox\fR command can return several pieces of information relevant to Extended Tcl, including the application's name, descriptive name, patch level and version. Your application's startup can set these variables to application-specific values. If it doesn't, they are given default values for Extended Tcl. .PP To set these values, first be sure that you include either \fBtclExtend.h\fR or \fBtclExtdInt.h\fR from the source file that defines your init routine. This will create external declarations for the variables. Then, set the variables in your init route, for example: .sp .nf .ft CW tclAppName = "cute"; tclAppLongName = "Call Unix/Tcl Environment"; tclAppVersion = "2.1"; .ft R .fi .PP Note that the default values are set by \fITclX_Init\fR, so if you wish to override them, you must call your init routine in \fITcl_AppInit\fR after its call to \fITclX_Init\fR. .PP .SH EXTENDED TCL EXIT .PP When Extended Tcl exits, \fBTcl_DeleteInterp\fR may be called to free memory used by Tcl -- normally, this is only called if \fBTCL_MEM_DEBUG\fR was defined, since Unix will return all of the allocated memory back to the system, anyway. If \fBTCL_MEM_DEBUG\fR was defined, it is called so that any memory that was allocated without ever being freed can be detected. This greatly reduces the amount of work to detect and track down memory leaks, a situation where some piece of your code allocates memory repeatedly without ever freeing it, or at least without always freeing it. .PP It is often necessary for an application to perform special cleanup functions upon the deletion of an interpreter as well. To facilitate this activity, Tcl provides the ability to perform a function callback when an interpreter is deleted. To arrange for a C function to be called when the interpreter is deleted, call \fBTcl_CallWhenDeleted\fR from your application initialization routine. For details on how to use this function, read the \fBCallDel\fR(3) manual page that ships with core Tcl. .PP .SH EXECUTING TCL CODE FROM YOUR C EXTENSION Suppose you are in the middle of coding a C extension and you realize that you need some operation performed, one that would be simple from Tcl, but possibly excruciating to do directly in C. Tcl provides a number of C-level interfaces whereby you can cause Tcl code to be executeed. The old-style calls are \fBTcl_Eval\fR, \fBTcl_VarEval\fR, \fBTcl_EvalFile\fR and \fBTcl_GlobalEval\fR. The results of these calls can be dug out of the interpreter using \fBTcl_GetStringResult\fR, if you want a string representation of the result, or \fBTcl_GetObjResult\fR if you want the object. (The use of \fBinterp->result\fR to access the result string has been deprecated.) .PP The Tcl object system adds \fBTcl_EvalObj\fR and \fBTcl_GlobalEvalObj\fR. The difference here is that we are evaluating an object, not just a string, and using these routines in preference to the aforementioned ones can result in a major performance improvement in your code, when the code is executed repeatedly (even if it only executes once but loops several times within itself), as these routines make it possible for the bytecode compiler to compile the code being evaluated and save the compiled code with the data structure, in an implementation-dependent manner. .PP For more information please consult the \fBEvalObj\fR(3) and \fBEval\fR(3) manual pages within the Tcl distribution. .PP .SH ACCESSING TCL VARIABLES AND ARRAYS FROM YOUR C EXTENSIONS In addition to the non-object-system ways of reading from and storing to Tcl variables, using routines such as \fBTcl_SetVar2\fR and \fBTcl_GetVar2\fR, Tcl variables and arrays can be read from a C extension as Tcl objects by using the \fBTcl_ObjGetVar2\fR function, and set from C extensions through the \fBTcl_ObjSetVar2\fR function. .PP Please note that the object versions do not carry forward analogues to the one-variable-name-argument \fBTcl_GetVar\fR, \fBTcl_SetVar\fR, and \fBTcl_UnsetVar\fR. If you know you have a scalar, call the object variable get and set functions with a NULL second argument. If your variable name might contain an array reference via a self-contained embedded array index (i.e., I'm asking \fBTcl_ObjGetVar2\fR for \fB"foo(5)"\fR instead of \fB"foo" "5"\fR), add the \fBTCL_PARSE_PART1\fR to the flags in your call. .PP While the fact that \fBTcl_ObjGetVar2\fR retrieves Tcl objects, rather than strings, is critical for the object system to be able to provide the performance boosts from "lazy" type conversion and the binary data capabilities, the arguments containing the variable name, or the array name and element name if they've been split out, also must be specified as Tcl objects rather than strings. While this is useful on occasion, those writing C extensions for Tcl in the post-object-system era usually have the names available as plain old \fIchar *\fR variables, requiring conversion of the strings to objects before use and account for their possible destruction afterwards. .PP To simplify the task in those cases, TclX adds the \fBTclX_ObjGetVar2S\fR subroutine. It works just like \fBTcl_ObjGetVar2\fR, except the one or two variable name arguments are specified as strings, and the routine takes care of making and disposing of object equivalents. .PP Tcl variables can be unset from C via the \fBTcl_UnsetVar\fR and \fBTcl_UnsetVar2\fR functions. There are currently (as of 8.0) no object-system equivalents, so in the rare case where you have the name of the variable you want unset as an object instead of a string, you can call \fBTcl_GetStringFromObj\fR to obtain the string representation first. .PP For complete information on these functions, please refer to the \fBObjSetVar\fR(3) and \fBSetVar\fR(3) manual pages in the \fIdoc\fR directory of the core Tcl distribution. .PP .SH LINKING TCL VARIABLES TO C VARIABLES \fBTcl_LinkVar\fR and \fBTcl_UnlinkVar\fR can be used to automatically keep Tcl variables synchronized with corresponding C variables. Once a Tcl variable has been linked to a C variable with \fBTcl_LinkVar\fR, anytime the Tcl variable is read, the value of the C variable is converted (if necessary) and returned, and when the Tcl variable is written, the C variable will be updated with the new value. .PP \fBTcl_LinkVar\fR uses variable traces to keep the Tcl variable named by \fIvarName\fR in sync with the C variable at the address given by \fIaddr\fR. .PP \fIInt\fR, \fIdouble\fR, \fIboolean\fR and \fIchar *\fR variables are supported. You can make your linked variables read only from the Tcl side, as well. Please note that the C variables must continually exist while they are linked, in other words, linking "automatic" C variables, those created on the stack while a routine is being executed and destroyed afterwards, will result in a malfunctioning program at best and a coredump or more at worst. .PP For more information, please examine the \fBLinkVar\fR(3) manual page in the core Tcl distribution. .PP .SH ADDING NEW MATH FUNCTIONS TO TCL As of Tcl version 7.0, math functions such as \fIsin\fR, \fIcos\fR, etc, are directly supported within Tcl expressions. These obsolete the Extended Tcl commands that provided explicit commands for these functions for many, many releases, although procs equivalencing the old TclX commands to the new math functions are still provided for backwards compatibility. .PP New math functions can be added to Tcl, or existing math functions can be replaced, by calling \fBTcl_CreateMathFunc\fR. .PP .SH ACCESSING AND MANIPULATING THE RANDOM NUMBER GENERATOR Prior to Tcl version 8.0, the Tcl core did not provide access to a random number generator, but TclX did, through its \fIrandom\fR command. As of Tcl version 8.0, access to a random number generator is provided by baseline Tcl through the new math functions, \fIrand\fR and \fIsrand\fR. .PP The TclX \fIrandom\fR command is still available -- it has some useful capabilities not directly provided by the new baseline functions. .PP For more information on adding your own math functions to Tcl, please study the \fBCrtMathFnc\fR(3) manual page in the core Tcl distribution. .PP .SH CONVERTING FILENAMES TO NATIVE FORM AND PERFORMING TILDE SUBSTITUTIONS The \fBTcl_TranslateFileName\fR function is available to C extension writers to translate filenames to a form suitable for use by the local operating system. It converts network names to their native form, and if the name starts with a ``~'' character, the function returns a new string where the name is replaced with the home directory of the given user. .PP For more information please consult the \fBTranslate\fR(3) manual page in the core Tcl distribution. .PP .SH SETTING THE RECURSION LIMIT Tcl has a preset recursion limit that limits the maximum allowable nesting depth of calls within an interpreter. This is useful for detecting infinite recursions before other limits such as the process memory limit or, worse, available swap space on the system, run out. .PP The default limit is just a guess, however, and applications that make heavy use of recursion may need to call \fBTcl_SetRecursionLimit\fR to raise this limit. For more information, please consult the \fBSetRecLmt\fR(3) manual page in the core Tcl distribution. .PP .SH HANDLING SIGNALS FROM TCL EXTENSIONS If an event such as a signal occurs while a Tcl script is being executed, it isn't safe to do much in the signal handling routine -- the Tcl environment cannot be safely manipulated at this point because it could be in the middle of some operation, such as updating pointers, leaving the interpreter in an unreliable state. .PP The only safe approach is to set a flag indicating that the event occurred, then handle the event later when the interpreter has returned to a safe state, such as after the current Tcl command completes. .PP The \fBTcl_AsyncCreate\fR, \fBTcl_AsyncMark\fR, \fBTcl_AsyncInvoke\fR, and \fBTcl_AsyncDelete\fR functions provide a safe mechanism for dealing with signals and other asynchronous events. For more information on how to use this capability, please refer to the \fBAsync\fR(3) manual page in the core Tcl distribution. .PP Note that Extended Tcl provides built-in support for managing signals in numerous ways, including generating them with \fIalarm\fR(2) and \fIkill\fR(2), ignoring them, trapping them, getting, setting, blocking and unblocking them. You can cause specific code to execute at a safe point after a signal occurs, or cause a Tcl error backtrace on one's occurrence. For more information, please examine the TclX documentation. .SH PARSING BACKSLASH SEQUENCES The \fBTcl_Backslash\fR function is called to parse Tcl backslash sequences. These backslash sequences are the usual sort that you see in the C programming language, such as \fB\\n\fR for newline, \fB\\r\fR for return, and so forth. \fBTcl_Backslash\fR parses a single backslash sequence and returns a single character corresponding to the backslash sequence. .PP For more info on this call, look at the \fBBackslash\fR(3) manual page in the core Tcl distribution. For information on the valid backslash sequences, consult the summary of Tcl language syntax, \fBTcl\fR(n) in the same distribution. .PP .SH HASH TABLES \fIHash tables\fR provide Tcl with a high-performance facility for looking up and managing key-value pairs located and maintained in memory. Tcl uses hash tables internally to locate procedure definitions, Tcl variables, array elements, file handles and so forth. Tcl makes the hash table functions accessible to C extension writers as well. .PP Hash tables grow automatically to maintain efficiency, rather than exposing the table size to the programmer at allocation time, which would needlessly add complexity to Tcl and would be prone to inefficiency due to the need to guess the number of items that will go into the table, and the seemingly inevitable growth in amount of data processed per run over the useful life of the program. .PP For more information on hash tables, please consult the \fBHash\fR(3) manual page in the core Tcl distribution. .PP .SH TRACING VARIABLE ACCESSES The C extension writer can arrange to have a C routine called whenever a Tcl variable is read, written, or unset. Variable traces are the mechanism by which Tk toolkit widgets such as radio and checkbuttons, messages and so forth update without Tcl programmer intervention when their data variables are changed. They are also used by the routine that links Tcl and C variables, \fBTcl_LinkVar\fR, described above. .PP \fBTcl_TraceVar\fR is called to establish a variable trace. Entire arrays and individual array elements can be traced as well. If the programmer already has an array name in one string and a variable name in another, \fBTcl_TraceVar2\fR can be called. Calls are also available to request information about traces and to delete them. .PP For more information on variable traces, consult the \fBTraceVar\fR(3) manual page in the core Tcl distribution. .PP .SH TRACING TCL EXECUTION Tcl has the ability to call C routines each time it executes a Tcl command, up to a specified depth of nesting levels. The command \fBTcl_CreateTrace\fR creates an execution trace; \fBTcl_DeleteTrace\fR deletes it. .PP Command tracing is used in Extended Tcl to implement the \fIcmdtrace\fR Tcl command, a useful command for debugging Tcl applications. .PP For complete information on execution tracing, please look at the \fBCrtTrace\fR(3) manual pages in the core Tcl distribution. .PP .SH EVALUATING TCL EXPRESSIONS FROM C \fBTcl_ExprLong\fR, \fBTcl_ExprDouble\fR, \fBTcl_ExprBool\fR, and \fBTcl_ExprString\fR all take string arguments and, when called, evaluate those strings as Tcl expressions. Depending on the routine called, the result is either a C \fIlong\fR, a \fIdouble\fR, a boolean (\fIint\fR with a value of \fB0\fR or \fI1\fR), or a \fIchar *\fR (obtainable through \fBTcl_GetResult\fR). .PP To take advantage of the performance gains available through the bytecode compiler, \fBTcl_ExprLongObj\fR, \fBTcl_ExprDoubleObj\fR, \fBTcl_ExprBoolObj\fR, and \fBTcl_ExprObj\fR all take an object containing an expression to be evaluated (rather than a string.) The result is that bytecode-compiled version of the expression will be kept in the object, alongside the string representation. If the expression is evaluated again, without being changed, it does not have to be recompiled... a major performance win. .PP For complete information on evaluating Tcl expressions from C, you are invited to examine the \fBExprLong\fR(3) and \fBExprLongObj\fR(3) manpages in the core Tcl distribution. .PP .SH PATTERN MATCHING The \fBTcl_StringMatch\fR function can be called to see if a string matches a specified pattern. \fBTcl_StringMatch\fR is called by the Tcl \fIstring match\fR command, so the format for patterns is identical. The pattern format is similar to the one used by the C-shell; \fBstring\fR(n) describes this format. .PP More information about \fBTcl_StringMatch\fR is available in the \fBStrMatch\fR(3) manpage in the core Tcl distribution. .PP .SH REGULAR EXPRESSION PATTERN MATCHING \fBTcl_RegExpMatch\fR can be called to determine whether a string matches a regular expression. \fBTcl_RegExpMatch\fR is used internally by the \fIregexp\fR Tcl command. .PP As regular expressions are typically "compiled" before use, a fairly involved process, Tcl also supports routines that separate the compilation of an expression from its use: \fBTcl_RegExpCompile\fR, \fBTcl_RegExpExec\fR, and \fBTcl_RegExpRange\fR. If an expression is going to be matched many times, doing the compile once and caching the compiled regular expression result, then reusing the cached version by using \fBTcl_RegExpExec\fR, can be a significant performance win. .PP For more information on this function, please consult the \fBRegExp\fR(3) manpage in the core Tcl distribution. .PP .SH MANIPULATING TCL LISTS FROM C EXTENSIONS The C extension writer often needs to create, manipulate and decompose Tcl lists. \fBTcl_SplitList\fR and \fBTcl_Merge\fR used to be the only way to parse strings into lists and vice versa. As of Tcl 8, lists can be parsed and assembled, object-style, using \fBTcl_ListObjGetElements\fR and \fBTcl_SetListObj\fR, and friends. Once again the "win" of using object-system-based list manipulation, instead of the previous string based routines, is that the parsing of a string in an object to a list is cached in the object structure, the same as with integers and floating point numbers, compiled procedures, etc. The next time this string needs to be looked at as a list, if the contents of the string have not changed, the string does not have to be parsed. .PP In the author's experience, working with an admittedly degenerate test whereby we iterated rather inefficiently across a 6,000-element list, a speedup factor of more than 2500 was obtained over the previous non-object-based version of Tcl. .PP For more information on these commands, please consult the \fBListObj\fR(3) manual page in the core Tcl distribution. .PP .SH CONCATENATING STRINGS \fBTcl_ConcatObj\fR concatenates the string representation of zero or more objects into a single new object. The elements of the new string are space-separated. \fBTcl_Concat\fR does the same thing for strings, as \fBTcl_ConcatObj\fR does for objects. .PP Concatenating strings is similar to constructing lists from them, except that \fBTcl_ConcatObj\fR and \fBTcl_Concat\fR do not attempt to make the resulting string into a valid Tcl list. .PP \fBTcl_Concat\fR is documented in the \fBConcat\fR(3) manpage, and \fBTcl_ConcatObj\fR in the \fBtringObj\fR manpage, both in the core Tcl distribution. .PP .SH DETECTING WHETHER OR NOT YOU HAVE A COMPLETE COMMAND C routines that collect data to form a command to be passed to \fITcl_Eval\fR often need a way to tell whether they have a complete command already or whether they need more data. (Programs that read typed-in Tcl input such as Tcl shells need this capability, for instance.) \fBTcl_CommandComplete\fR can be used to tell whether or not you have a complete command. .PP For more information examine \fBCmdCmplt\fR(3) in the core Tcl distribution. .PP .SH RECORDING COMMANDS FOR COMMAND HISTORY Tcl has a history mechanism that is accessed from Tcl through the \fIhistory\fR command. If you want your extension to propagate commands into the command history, you should call \fITcl_RecordAndEvalObj\fR (object system) or \fITcl_RecordAndEval\fR (old system), .PP These commands work like \fITcl_EvalObj\fR and \fITcl_Eval\fR, respectively, except that these versions record the command as well as executing it. .PP \fITcl_RecordAndEval\fR and \fITcl_RecordAndEvlObj\fR should only be called with user-entered top-level commands, since the history mechanism exists to allow the user to easily access, edit and reissue previously issued commands. .PP For complete information on these functions, please examine the \fBRecordEval\fR.3 and \fBRecEvalObj\fR.3 manual pages in the core Tcl distribution. .PP .SH CONVERTING FLOATING POINT VALUES TO STRINGS The Tcl object system's \fBTcl_GetDoubleFromObj\fR and \fBTcl_SetDoubleObj\fR use Tcl objects, rather than the strings used by \fBTcl_PrintDouble\fR, and convert, when necessary, an ASCII string to a \fIdouble\fR and back again. .PP These routines ensure that the string output will continue to be interpretable as a floating point number, rather than an integer, by always putting a ``.'' or ``e'' into the string representing the number. .PP The precision of the output string is controlled by the Tcl \fBtcl_precision\fR variable. .PP For complete information on these routines, please examine \fBDoubleObj\fR(3) and \fBPrintDbl\fR(3) in the core Tcl distribution. .PP .SH CREATING CHILD PROCESSES AND PIPELINES FROM C \fBTcl_OpenCommandChannel\fR provides a C-level interface to the \fBexec\fR and \fBopen\fR commands. The child (or pipeline of children) can have its standard input, output and error redirected from files, variables or pipes. To understand the meaning of the redirection symbols understood by this function, look at the \fBexec\fR(n) Tcl command. For complete information on \fBTcl_OpenCommandChannel\fR, please examine \fBOpenFileChnl\fR(3). .PP .SH ACCESSING TCL FILEHANDLES FROM C On Posix/Unix systems, Tcl filehandles passed to your C extension can be translated to a Posix \fIFILE *\fR structure using the \fBTcl_GetOpenFile\fR function, documented in \fBGetOpnFl\fR.3. .PP .SH MANAGING BACKGROUND PROCESS TERMINATION AND CLEANUP When a Posix system does a \fIfork\fR to create a new process, the process ID of the child is returned to the caller. After the child process exits, its process table entry (and some other data associated with the process) cannot be reclaimed by the operating system until a call to \fIwaitpid\fR, or one of a couple of other, similar system calls, has been made by the parent process. .PP The C extension writer who has created a subprocess, by whatever mechanism, can turn over responsibility for detecting the processes' termination and calling \fIwaitpid\fR to obtain its exit status, by calling \fBTcl_DetachPids\fR on it. .PP \fBTcl_ReapDetachedProcs\fR is the C routine that will detect the termination of any processes turned over to Tcl, permitting the processes to be fully reclaimed by the operating system. It is usually not necessary to call \fBTcl_ReapDetachedProcs\fR, as it is called automatically every time \fBexec\fR is performed. .PP For complete information on these routines, please look at \fIDetachPids(3)\fR in the core Tcl distribution. .PP .SH FOR MORE INFORMATION .PP In addition to the documentation referenced above, you can learn a lot by studying the source code of the commands added by Tcl, Tk and Extended Tcl, etc. The \fIcomp.lang.tcl\fR Usenet newsgroup is read by hundreds of thousands of Tcl people. A number of Frequently Asked Questions (FAQs) about Tcl are posted there periodically. The newsgroup is a good place to ask questions (after you've made sure they're not already answered in the FAQ ;-) .PP Finally, if you have interactive Internet access, you can ftp to \fIftp://ftp.neosoft.com/pub/tcl\fR, the site for contributed Tcl sources. This site contains quite a few extensions, applications, and so forth, including several object-oriented extension packages. .PP If you have access via the world-wide web, check out the Sun Microsystems site (\fIhttp://sunscript.sun.com\fR), the contributed sources archive website (\fIhttp://www.neosoft.com/tcl\fR), and the homepage for Extended Tcl (\fIhttp://www.neosoft.com/tclx\fR). .PP .SH AUTHORS .PP Extended Tcl was created by Karl Lehenbauer (karl@neosoft.com) and Mark Diekhans (markd@grizzly.com). .PP tclx8.4-8.4.1.orig/doc/CmdWrite.30000644000000000000000000010211612046313167013130 0ustar .\" .\" CmdWrite.3 .\" .\" Command writing manual. .\"---------------------------------------------------------------------------- .\" Copyright 1992-1999 Karl Lehenbauer and Mark Diekhans. .\" .\" Permission to use, copy, modify, and distribute this software and its .\" documentation for any purpose and without fee is hereby granted, provided .\" that the above copyright notice appear in all copies. Karl Lehenbauer and .\" Mark Diekhans make no representations about the suitability of this .\" software for any purpose. It is provided "as is" without express or .\" implied warranty. .\"---------------------------------------------------------------------------- .\" $Id: CmdWrite.3,v 8.2 1999/03/31 06:37:41 markd Exp $ .\"---------------------------------------------------------------------------- .\" .TH "Command Writing" TCL "" "Tcl" .ad b .SH NAME TclCommandWriting - Writing C language extensions to Tcl. ' .SH OVERVIEW This document is intended to help the programmer who wishes to extend Tcl with C language routines. It should also be useful to someone wishing to add Tcl to an existing editor, communications program, window manager, etc. C programming information can also be found in the \fI*.3\fR manual pages in the \fIdoc\fR directory of the Berkeley distribution, and in the \fI*.3\fR manpages in the \fIman\fR directory of Extended Tcl. ' .SH WRITING TCL EXTENSIONS IN C All C-based Tcl commands are called with four arguments: a client data pointer, an interpreter pointer, an argument count and a pointer to an array of pointers to character strings containing the Tcl arguments to the command. .PP A simple Tcl extension in C is now presented, and described below: .sp .nf .ft CW #include "tcl.h" int App_EchoCmd(clientData, interp, argc, argv) void *clientData; Tcl_Interp *interp; int argc; char **argv; { int i; for (i = 1; i < argc; i++) { printf("%s",argv[i]); if (i < argc - 1) printf(" "); } printf("\\n"); return TCL_OK; } .ft R .fi .PP The client data pointer will be described later. .PP The interpreter pointer is the ``key'' to an interpreter. It is returned by \fBTcl_CreateInterp\fR and is used extensively within Tcl, and will be by your C extensions. The data structure pointed to by the interpreter pointer, and all of the subordinate structures that branch off of it, make up a Tcl interpreter, which includes all of the currently defined procedures, commands, variables, arrays and the execution state of that interpreter. (For more information on creating and deleting interpreters, please examine the \fBCrtInterp\fR(3) manpage in the Berkeley Tcl distribution. For information on creating interpreters that include the commands provided by Extended Tcl, check out the \fBTclX_Init\fR(3) manpage of Extended Tcl. For a manual page describing the user-visible fields of a Tcl interpreter, please look at \fBInterp\fR(3) in Berkeley Tcl.) .PP The argument count and pointer to an array of pointers to textual arguments is handled by your C code in the same manner that you would use in writing a C \fImain\fR function -- the argument count and array of pointers works the same as in a C \fImain\fR call; pointers to the arguments to the function are contained in the \fIargv\fR array. Similar to a C main, the first argument (\fIargv[0]\fR) is the name the routine was called as (in a main, the name the program was invoked as). .PP In the above example, all of the arguments are output with a space between each one by looping through \fIargv\fR from one to the argument count, \fIargc\fR, and a newline is output to terminate the line -- an ``echo'' command. .PP All arguments from a Tcl call to a Tcl C extension are passed as strings. If your C routine expects certain numeric arguments, your routine must first convert them using the \fBTcl_GetInt\fR or \fBTcl_GetDouble\fR function, Extended Tcl's \fBTcl_GetLong\fR or \fBTcl_GetUnsigned\fR, or some other method of your own devising. Likewise for converting boolean values, \fBTcl_GetBoolean\fR should be used. These routines automatically leave an appropriate error message in the Tcl interpreter's result buffer and return \fBTCL_ERROR\fR if a conversion error occurs. (For more information on these routines, please look at the \fBGetInt\fR(3) manpage in the Berkeley Tcl distribution.) .PP Likewise, if you program produces a numeric result, it should return a string equivalent to that numeric value. A common way of doing this is something like... .sp .nf .ft CW sprintf(interp->result, "%ld", result); .ft R .fi .PP Writing results directly into the interpreter's result buffer is only good for relatively short results. Tcl has a function, \fBTcl_SetResult\fR, which provides the ability for your C extensions to return very large strings to Tcl, with the ability to tell the interpreter whether it ``owns'' the string (meaning that Tcl should delete the string when it's done with it), that the string is likely to be changed or overwritten soon (meaning that Tcl should make a copy of the string right away), or that the string won't change (so Tcl can use the string as is and not worry about it). Understanding how results are passed back to Tcl is essential to the C extension writer. Please study the \fBSetResult\fR(3) manual page in the Tcl distribution. .PP Sophisticated commands should verify their arguments whenever possible, both by examining the argument count, by verifying that numeric fields are really numeric, that values are in range (when their ranges are known), and so forth. .PP Tcl is designed to be as bullet-proof as possible, in the sense that no Tcl program should be able to cause Tcl to dump core. Please carry this notion forward with your C extensions by validating arguments as above. .PP .SH ANOTHER C EXTENSION - THE MAX COMMAND In the command below, two or more arguments are compared and the one with the maximum value is returned, if all goes well. It is an error if there are fewer than three arguments (the pointer to the ``max'' command text itself, \fIargv[0]\fR, and pointers to at least two arguments to compare the values of). .PP This routine also shows the use of the programmer labor-saving \fBTcl_AppendResult\fR routine. See the Tcl manual page, \fBSetResult\fR(3), for details. Also examine the calls \fBTcl_AddErrorInfo\fR, \fBTcl_SetErrorCode\fR and \fBTcl_PosixError\fR documented in the Tcl manual page \fBAddErrInfo\fR(3). .sp .nf .ft CW int Tcl_MaxCmd (clientData, interp, argc, argv) char *clientData; Tcl_Interp *interp; int argc; char **argv; { int maxVal = MININT; int maxIdx = 1; int value, idx; if (argc < 3) { Tcl_AppendResult (interp, "bad # arg: ", argv[0], " num1 num2 [..numN]", (char *)NULL); return TCL_ERROR; } for (idx = 1; idx < argc; idx++) { if (Tcl_GetInt (argv[idx], 10, &Value) != TCL_OK) return TCL_ERROR; if (value > maxVal) { maxVal = value; maxIdx = idx; } } Tcl_SetResult (interp, argv [maxIdx], TCL_VOLATILE); return TCL_OK; } .ft R .fi .PP When Tcl-callable functions complete, they should normally return \fBTCL_OK\fR or \fBTCL_ERROR\fR. \fBTCL_OK\fR is returned when the command succeeded and \fBTCL_ERROR\fR is returned when the command has failed in some abnormal way. \fBTCL_ERROR\fR should be returned for all syntax errors, non-numeric values (when numeric ones were expected), and so forth. Less clear in some cases is whether Tcl errors should be returned or whether a function should just return a status value. For example, end-of-file during a \fIgets\fR returns a status, but \fIopen\fR returns an error if the open fails. Errors can be caught from Tcl programs using the \fIcatch\fR command. (See Tcl's \fBcatch\fR(n) and \fBerror\fR(n) manual pages.) .PP Less common return values are \fBTCL_RETURN\fR, \fBTCL_BREAK\fR and \fBTCL_CONTINUE\fR. These are used if you are adding new control and/or looping structures to Tcl. To see these values in action, examine the source code to Tcl's \fIwhile\fR, \fIfor\fR and \fIif\fR, and Extended Tcl's \fIloop\fR commands. .PP Note the call to \fITcl_SetResult\fR in the above command to set the return value to Tcl. \fBTCL_VOLATILE\fR is used because the memory containing the result will be freed upon the function's return. .SH ANOTHER C EXTENSION - THE LREVERSE COMMAND In the command below, one list is passed as an argument, and a list containing all of the elements of the list in reverse order is returned. It is an error if anything other than two arguments are passed (the pointer to the ``lreverse'' command text itself, \fIargv[0]\fR, and a pointer to the list to reverse. .PP Once \fIlreverse\fR has determined that it has received the correct number of arguments, \fBTcl_SplitList\fR is called to break the list into an \fIargc\fR and \fIargv\fR array of pointers. .PP \fIlreverse\fR then operates on the array of pointers, swapping them from lowest to highest, second-lowest to second-highest, and so forth. .PP Finally \fBTcl_Merge\fR is calleds to create a single new string containing the reversed list and it is set as the result via \fBTcl_SetResult\fR. Note that \fBTCL_DYNAMIC\fR is used to tell \fBTcl_SetResult\fR that it now owns the string and it is up to Tcl to free the string when it is done with it. .PP Note that it \fIis\fR safe to play around with the \fIargv\fR list like this, and that a single call to \fBckfree\fR can be made to free all the data returned by \fBTcl_SplitList\fR in this manner. .PP .sp .nf .ft CW int Tcl_LreverseCmd(notUsed, interp, argc, argv) ClientData notUsed; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ char **argv; /* Argument strings. */ { int listArgc, lowListIndex, hiListIndex; char **listArgv; char *temp, *resultList; if (argc != 2) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " list\"", (char *) NULL); return TCL_ERROR; } if (Tcl_SplitList(interp, argv[1], &listArgc, &listArgv) != TCL_OK) { return TCL_ERROR; } for (lowListIndex = 0, hiListIndex = listArgc; --hiListIndex > lowListIndex; lowListIndex++) { temp = listArgv[lowListIndex]; listArgv[lowListIndex] = listArgv[hiListIndex]; listArgv[hiListIndex] = temp; } resultList = Tcl_Merge (listArgc, listArgv); ckfree (listArgv); Tcl_SetResult (interp, resultList, TCL_DYNAMIC); return TCL_OK; } .ft R .fi .PP ' .SH INSTALLING YOUR COMMAND .P To install your command into Tcl you must call \fBTcl_CreateCommand\fR, passing it the pointer to the interpreter you want to install the command into, the name of the command, a pointer to the C function that implements the command, a client data pointer, and a pointer to an optional callback routine. .PP The client data pointer and the callback routine will be described later. .PP For example, for the max function above (which, incidentally, comes from TclX's tclXmath.c in the \fITclX7.4/src\fR directory): .sp .nf .ft CW Tcl_CreateCommand (interp, "max", Tcl_MaxCmd, (ClientData)NULL, (void (*)())NULL); .ft R .fi .PP In the above example, the max function is added to the specified interpreter. The client data pointer and callback function pointer are NULL. (For complete information on \fBTcl_CreateCommand\fR and its companion routine, \fBTcl_CommandInfo\fR, please examine the \fBCrtCommand\fR(3) command page in the Berkeley Tcl distribution.) .PP .SH DYNAMIC STRINGS .PP \fIDynamic strings\fR are an important abstraction that first became available with Tcl 7.0. Dynamic strings, or \fIDStrings\fR, provide a way to build up arbitrarily long strings through a repeated process of appending information to them. DStrings reduce the amount of allocating and copying required to add information to a string. Further, they simplify the process of doing so. For complete information on dynamic strings, please examine the \fBDString\fR(3) manual page in the Berkeley Tcl distribution. .PP .SH CLIENT DATA .PP The client data pointer provides a means for Tcl commands to have data associated with them that is not global to the C program nor included in the Tcl core. Client data is essential in a multi-interpreter environment (where a single program has created and is making use of multiple Tcl interpreters) for the C routines to maintain any permanent data they need on a per-interpreter basis. Otherwise there would be reentrancy problems. Tcl solves this through the client data mechanism. When you are about to call \fBTcl_CreateCommand\fR to add a new command to an interpreter, if that command needs to keep some read/write data across invocations, you should allocate the space, preferably using \fBckalloc\fR, then pass the address of that space as the ClientData pointer to \fBTcl_CreateCommand\fR. .PP When your command is called from Tcl, the ClientData pointer you gave to \fBTcl_CreateCommand\fR when you added the command to that interpreter is passed to your C routine through the ClientData pointer calling argument. .PP Commands that need to share this data with one another can do so by using the same ClientData pointer when the commands are added. .PP It is important to note that the Tcl extensions in the \fItclX7.4/src\fR directory have had all of their data set up in this way. Since release 6.2, Extended Tcl has supported multiple interpreters within one invocation of Tcl. ' .SH THEORY OF HANDLES Sometimes you need to have a data element that isn't readily representable as a string within Tcl, for example a pointer to a complex C data structure. It is not a good idea to try to pass pointers around within Tcl as strings by converting them to and from hex or integer representations, for example. It is too easy to mess one up, and the likely outcome of doing that is a core dump. .PP Instead we have developed and made use of the concept of \fIhandles\fR. Handles are identifiers a C extension can pass to, and accept from, Tcl to make the transition between what your C code knows something as and what name Tcl knows it by to be as safe and painless as possible. For example, the stdio package included in Tcl uses file handles. When you open a file from Tcl, a handle is returned of the form \fBfile\fIn\fR where \fIn\fR is a file number. When you pass the file handle back to \fIputs\fR, \fIgets\fR, \fIseek\fR, \fIflush\fR and so forth, they validate the file handle by checking the the \fBfile\fR text is present, then converting the file number to an integer that they use to look into a data structure of pointers to Tcl open file structures, which contain a Unix file descriptor, flags indicating whether or not the file is currently open, whether the file is a file or a pipe and so forth. .PP Handles have proven so useful that, as of release 6.1a, general support has been added for them. If you need a similar capability, it would be best to use the handle routines, documented in \fBHandles\fR(3) in Extended Tcl. We recommend that you use a unique-to-your-package textual handle coupled with a specific identifier and let the handle management routines validate it when it's passed back. It is much easier to track down a bug with an implicated handle named something like \fBfile4\fR or \fBbitmap6\fR than just \fB6\fR. .PP .SH TRACKING MEMORY CORRUPTION PROBLEMS Occasionally you may write code that scribbles past the end of an allocated piece of memory. The memory debugging routines included in Tcl can help find these problems. See \fIMemory(TCL)\fR for details. .PP .SH INSTALLING YOUR EXTENSIONS INTO EXTENDED TCL To add your extensions to Extended Tcl, you must compile them and cause them to be linked with TclX. For the routines to be linked into the \fBtcl\fR and \fBwishx\fR executables, they must be referenced (directly or indirectly) from TclX. For these extensions to be visible as Tcl commands, they must be installed into Tcl with \fBTcl_CreateCommand\fR. .PP Application-specific startup is accomplished by creating or editing the \fITcl_AppInit\fR function. In \fITcl_AppInit\fR you should add a call to an application-specific init function which you create. This function should take the address of the interpreter it should install its commands into, and it should install those commands with \fBTcl_CreateCommand\fR and do any other application-specific startup that is necessary. .PP The naming convention for application startup routines is \fBApp_Init\fR, where \fIApp\fR is the name of your application. For example, to add an application named \fIcute\fR one would create a \fICute_Init\fR routine that expected a \fBTcl_Interp\fR pointer as an argument, and add the following code to \fITcl_AppInit\fR: .sp .nf .ft CW if (Cute_Init (interp) == TCL_ERROR) { return TCL_ERROR; } .ft R .fi .PP As you can guess from the above example, if your init routine is unable to initialize, it should use \fBTcl_AppendResult\fR to provide some kind of useful error message back to TclX, then return \fBTCL_ERROR\fR to indicate that an error occurred. If the routine executed successfully, it should return \fBTCL_OK\fR. .PP When you examine \fITcl_AppInit\fR, note that there is one call already there to install an application -- the call to \fITclX_Init\fR installs Extended Tcl into the Tcl core. .SH MAKING APPLICATION INFORMATION VISIBLE FROM EXTENDED TCL TclX's \fBinfox\fR command can return several pieces of information relevant to Extended Tcl, including the application's name, descriptive name, patch level and version. Your application's startup can set these variables to application-specific values. If it doesn't, they are given default values for Extended Tcl. .PP To set these values, first be sure that you include either \fBtclExtend.h\fR or \fBtclExtdInt.h\fR from the source file that defines your init routine. This will create external declarations for the variables. Then, set the variables in your init route, for example: .sp .nf .ft CW tclAppName = "cute"; tclAppLongName = "Call Unix/Tcl Environment"; tclAppVersion = "2.1"; .ft R .fi .PP Note that the default values are set by \fITclX_Init\fR, so if you wish to override them, you must call your init routine in \fITcl_AppInit\fR after its call to \fITclX_Init\fR. .PP .SH EXTENDED TCL EXIT .PP When Extended Tcl exits, \fBTcl_DeleteInterp\fR may be called to free memory used by Tcl -- normally, this is only called if \fBTCL_MEM_DEBUG\fR was defined, since Unix will return all of the allocated memory back to the system, anyway. If \fBTCL_MEM_DEBUG\fR was defined, it is called so that any memory that was allocated without ever being freed can be detected. This greatly reduces the amount of work to detect and track down memory leaks, a situation where some piece of your code allocates memory repeatedly without ever freeing it, or without always freeing it. .PP It is often necessary for an application to perform special cleanup functions upon the deletion of an interpreter as well. To facilitate this activity, Tcl provides the ability to perform a function callback when an interpreter is deleted. To arrange for a C function to be called when the interpreter is deleted, call \fBTcl_CallWhenDeleted\fR from your application initialization routine. For details on how to use this function, read the \fBCallDel\fR(3) manual page that ships with Berkeley Tcl. .PP .SH EXECUTING TCL CODE FROM YOUR C EXTENSION Suppose you are in the middle of coding a C extension and you realize that you need some operation performed, one that would be simple from Tcl but possibly excruciating to do directly in C. Tcl provides the \fBTcl_Eval\fR, \fBTcl_VarEval\fR, \fBTcl_EvalFile\fR and \fBTcl_GlobalEval\fR functions for the purpose of executing Tcl code from within a C extension. The results of the call will be in \fBinterp->result\fR. For more information please consult the \fBEval\fR(3) manual page within the Tcl distribution. .PP .SH ACCESSING TCL VARIABLES AND ARRAYS FROM YOUR C EXTENSIONS Tcl variables and arrays can be read from a C extension through the \fBTcl_GetVar\fR and \fBTcl_GetVar2\fR functions, and set from C extensions through the \fBTcl_SetVar\fR and \fBTcl_SetVar2\fR functions. They can also be unset via the \fBTcl_UnsetVar\fR and \fBTcl_UnsetVar2\fR functions. For complete information on these functions, please refer to the \fBSetVar\fR(3) manual page in the \fIdoc\fR directory of the Berkeley Tcl distribution. .PP .SH LINKING TCL VARIABLES TO C VARIABLES \fBTcl_LinkVar\fR and \fBTcl_UnlinkVar\fR can be used to automatically keep Tcl variables synchronized with corresponding C variables. Once a Tcl variable has been linked to a C variable with \fBTcl_LinkVar\fR, anytime the Tcl variable is read the value of the C variable will be returned, and when the Tcl variable is written, the C variable will be updated with the new value. .PP \fBTcl_LinkVar\fR uses variable traces to keep the Tcl variable named by \fIvarName\fR in sync with the C variable at the address given by \fIaddr\fR. .PP Whenever the Tcl variable is read the value of the C variable will be returned, and whenever the Tcl variable is written the C variable will be updated to have the same value. .PP \fIInt\fR, \fIdouble\fR, \fIboolean\fR and \fIchar *\fR variables are supported. For more information, please examine the \fBLinkVar\fR(3) manual page in the Berkeley Tcl distribution. .PP .SH ADDING NEW MATH FUNCTIONS TO TCL As of Tcl version 7.0, math functions such as \fIsin\fR, \fIcos\fR, etc, are directly supported within Tcl expressions. These obsolete the Extended Tcl commands that provided explicit calls for these functions for many releases. .PP New math functions can be added to Tcl, or existing math functions can be replaced, by calling \fBTcl_CreateMathFunc\fR. .PP For more information on adding math functions, please examine the \fBCrtMathFnc\fR(3) manual page in the Berkeley Tcl distribution. .PP .SH PERFORMING TILDE SUBSTITUTIONS ON FILENAMES The \fBTcl_TildeSubst\fR function is available to C extension writers to perform tilde substitutions on filenames. If the name starts with a ``~'' character, the function returns a new string where the name is replaced with the home directory of the given user. For more information please consult the \fBTildeSubst\fR(3) manual page in the Berkeley Tcl distribution. .PP .SH SETTING THE RECURSION LIMIT Tcl has a preset recursion limit that limits the maximum allowable nesting depth of calls within an interpreter. This is useful for detecting infinite recursions before other limits such as the process memory limit or, worse, available swap space on the system, are exceeded. .PP The default limit is just a guess, however, and applications that make heavy use of recursion may need to call \fBTcl_SetRecursionLimit\fR to raise this limit. For more information, please consult the \fBSetRecLmt\fR(3) manual page in the Berkeley Tcl distribution. .PP .SH HANDLING SIGNALS FROM TCL EXTENSIONS If an event such as a signal occurs while a Tcl script is being executed, it isn't safe to do much in the signal handling routine -- the Tcl environment cannot be safely manipulated at this point because it could be in the middle of some operation, such as updating pointers, leaving the interpreter in an unreliable state. .PP The only safe approach is to set a flag indicating that the event occurred, then handle the event later when the interpreter has returned to a safe state, such as after the current Tcl command completes. .PP The \fBTcl_AsyncCreate\fR, \fBTcl_AsyncMark\fR, \fBTcl_AsyncInvoke\fR, and \fBTcl_AsyncDelete\fR functions provide a safe mechanism for dealing with signals and other asynchronous events. For more information on how to use this capability, please refer to the \fBAsync\fR(3) manual page in the Berkeley Tcl distribution. .SH PARSING BACKSLASH SEQUENCES The \fBTcl_Backslash\fR function is called to parse Tcl backslash sequences. These backslash sequences are the usual sort that you see in the C programming language, such as \fB\\n\fR for newline, \fB\\r\fR for return, and so forth. \fBTcl_Backslash\fR parses a single backslash sequence and returns a single character corresponding to the backslash sequence. .PP For more info on this call, look at the \fBBackslash\fR(3) manual page in the Berkeley Tcl distribution. For information on the valid backslash sequences, consult the summary of Tcl language syntax, \fBTcl\fR(n) in the same distribution. .PP .SH HASH TABLES \fIHash tables\fR provide Tcl with a high-performance facility for looking up and managing key-value pairs located and maintained in memory. Tcl uses hash tables internally to locate procedure definitions, Tcl variables, array elements, file handles and so forth. Tcl makes the hash table functions accessible to C extension writers as well. .PP Hash tables grow automatically to maintain efficiency, rather than exposing the table size to the programmer at allocation time, which would needlessly add complexity to Tcl and would be prone to inefficiency due to the need to guess the number of items that will go into the table, and the seemingly inevitable growth in amount of data processed per run over the life of the program. .PP For more information on hash tables, please consult the \fBHash\fR(3) manual page in the Berkeley Tcl distribution. .PP .SH TRACING VARIABLE ACCESSES The C extension writer can arrange to have a C routine called whenever a Tcl variable is read, written, or unset. Variable traces are the mechanism by which Tk toolkit widgets such as radio and checkbuttons, messages and so forth update without Tcl programmer intervention when their data variables are changed. They are also used by the routine that links Tcl and C variables, \fBTcl_LinkVar\fR, described above. .PP \fBTcl_TraceVar\fR is called to establish a variable trace. Entire arrays and individual array elements can be traced as well. If the programmer already has an array name in one string and a variable name in another, \fBTcl_TraceVar2\fR can be called. Calls are also available to request information about traces and to delete them. .PP For more information on variable traces, consult the \fBTraceVar\fR(3) manual page in the Berkeley Tcl distribution. .PP .SH TRACING EXECUTION Tcl has the ability to call C routines for every command it executes, up to a specified depth of nesting levels. The command \fBTcl_CreateTrace\fR creates an execution trace; \fBTcl_DeleteTrace\fR deletes it. .PP Command tracing is used in Extended Tcl to implement the \fIcmdtrace\fR Tcl command, a useful command for debugging Tcl applications. .PP For complete information on execution tracing, please look at the \fBCrtTrace\fR(3) manual pages in the Berkeley Tcl distribution. .PP .SH EVALUATING TCL EXPRESSIONS FROM C \fBTcl_ExprLong\fR, \fBTcl_ExprDouble\fR, \fBTcl_ExprBool\fR, and \fBTcl_ExprString\fR can be called to evaluate Tcl expressions from within a C routine. Depending on the routine called, the result is either a C \fIlong\fR, a \fIdouble\fR, a boolean (\fIint\fR with a value of \fB0\fR or \fI1\fR), or a \fIchar *\fR (pointed to by \fIinterp->result\fR). .PP For complete information on evaluating Tcl expressions from C, you are invited to examine the \fBExprLong\fR(3) manpage in the Berkeley Tcl distribution. .PP .SH PATTERN MATCHING The \fBTcl_StringMatch\fR function can be called to see if a string matches a specified pattern. \fBTcl_StringMatch\fR is called by the Tcl \fIstring match\fR command, so the format for patterns is identical. The pattern format is similar to the one used by the C-shell; \fBstring\fR(n) describes this format. .PP More information about \fBTcl_StringMatch\fR is available in the \fBStrMatch\fR(3) manpage in the Berkeley Tcl distribution. .PP .SH REGULAR EXPRESSION PATTERN MATCHING \fBTcl_RegExpMatch\fR can be called to determine whether a string matches a regular expression. \fBTcl_RegExpMatch\fR is used internally by the \fIregexp\fR Tcl command. .PP For more information on this function, please consult the \fBRegExp\fR(3) manpage in the Berkeley Tcl distribution. .PP .SH MANIPULATING TCL LISTS FROM C EXTENSIONS The C extension writer often needs to create, manipulate and decompose Tcl lists. \fBTcl_SplitList\fR parses a list into an \fIargv\fR and \fIargc\fR like to the way command-line arguments are passed to a Tcl extension. \fBTcl_Merge\fR, likewise, creates a single string (pointer to a \fIchar *\fR) from an \fIargv\fR and \fIargc\fR. .PP Two routines, \fBTcl_ScanElement\fR and \fBTcl_ConvertElement\fR, do most of the work of \fBTcl_Merge\fR, and may also be of use to the C programmer. .PP For more information on these commands, please consult the \fBSplitList\fR(3) manual page in the Berkeley Tcl distribution. .PP .SH CONCATENATING STRINGS \fBTcl_Concat\fR concatenates zero or more strings into a single string. The strings are space-separated. \fBTcl_Concat\fR works like \fITcl_Merge\fR, except that \fBTcl_Concat\fR does not attempt to make the resulting string into a valid Tcl list. .PP \fBTcl_Concat\fR is documented in the \fBConcat\fR(3) manpage in the Berkeley Tcl distribution. .PP .SH DETECTING WHETHER OR NOT YOU HAVE A COMPLETE COMMAND C routines that collect data to form a command to be passed to \fITcl_Eval\fR often need a way to tell whether they have a complete command already or whether they need more data. (Programs that read typed-in Tcl input such as Tcl shells need this capability.) \fBTcl_CommandComplete\fR can be used to tell whether or not you have a complete command. .PP For more information examine \fBCmdCmplt\fR(3) in the Berkeley Tcl distribution. .PP .SH RECORDING COMMANDS FOR COMMAND HISTORY Tcl has a history mechanism that is accessed from Tcl through the \fIhistory\fR command. To propagate commands into the command history, your extension should call \fITcl_RecordAndEval\fR. This command works just like \fITcl_Eval\fR, except that it records the command as well as executing it. .PP \fITcl_RecordAndEval\fR should only be called with user-entered top-level commands, since the history mechanism exists to allow the user to easily access, edit and reissue previously issued commands. .PP For complete information on this function, please examine the \fBRecordEval\fR.3 manual page in the Berkeley Tcl distribution. .PP .SH CONVERTING FLOATING POINT VALUES TO STRINGS \fBTcl_PrintDouble\fR converts a C \fIdouble\fR into an ASCII string. It ensures that the string output will continue to be interpreted as a floating point number, rather than an integer, by always putting a ``.'' or ``e'' into the string representing the number. The precision of the output string is controlled by the Tcl \fBtcl_precision\fR variable. .PP For complete information on \fITcl_PrintDouble\fR, examine \fBPrintDbl\fR(3) in the Berkeley Tcl distribution. .PP .SH CREATING CHILD PROCESSES AND PIPELINES FROM C \fBTcl_CreatePipeline\fR is a useful procedure for spawning child processes. The child (or pipeline of children) can have its standard input, output and error redirected from files, variables or pipes. To understand the meaning of the redirection symbols understood by this function, look at the \fBexec\fR(n) Tcl command. For complete information on \fBTcl_CreatePipeline\fR, please examine \fBCrtPipelin\fR(3). .PP .SH ACCESSING TCL FILEHANDLES FROM C Files opened from your C code can be made visible to Tcl code via the \fBTcl_EnterFile\fR function. Likewise, Tcl filehandles passed to your C extension can be translated to a Posix \fIFILE *\fR structure using the \fBTcl_GetOpenFile\fR function. .PP For complete explanations of these commands, please look at \fBEnterFile\fR(3) in the Berkeley Tcl distribution. .SH MANAGING BACKGROUND PROCESS TERMINATION AND CLEANUP When a Posix system does a \fIfork\fR to create a new process, the process ID of the child is returned to the caller. After the child process exits, its process table entry (and some other data associated with the process) cannot be reclaimed by the operating system until a call to \fIwaitpid\fR, or one of a couple of other, similar system calls, has been made by the parent process. .PP The C extension writer who has created a subprocess, by whatever mechanism, can turn over responsibility for detecting the processes' termination and calling \fIwaitpid\fR to obtain its exit status by calling \fBTcl_DetachPids\fR. .PP \fBTcl_ReapDetachedProcs\fR is the C routine that will detect the termination of any processes turned over to Tcl, permitting the processes to be fully reclaimed by the operating system. .PP For complete information on these routines, please look at \fIDetachPids(3)\fR in the Berkeley Tcl distribution. .PP .SH FOR MORE INFORMATION .PP In addition to the documentation referenced above, you can learn a lot by studying the source code of the commands added by Tcl, Tk and Extended Tcl. The \fIcomp.lang.tcl\fR Usenet newsgroup is read by tens of thousands of Tcl people, and is a good place to ask questions. Finally, if you have interactive Internet access, you can ftp to \fIftp.aud.alcatel.com\fR, the site for contributed Tcl sources. This site contains quite a few extensions, applications, and so forth, including several object-oriented extension packages. .PP .SH AUTHORS .PP Extended Tcl was created by Karl Lehenbauer (karl@neosoft.com) and Mark Diekhans (markd@grizzly.com). .PP tclx8.4-8.4.1.orig/doc/TclX.n0000644000000000000000000031123112046313167012357 0ustar .\" .\" TclX.n .\" .\" Extended command set and environment for Tcl. .\"---------------------------------------------------------------------------- .\" Copyright 1992-1999 Karl Lehenbauer and Mark Diekhans. .\" Copyright 2004 ActiveState Corporation. .\" .\" Permission to use, copy, modify, and distribute this software and its .\" documentation for any purpose and without fee is hereby granted, provided .\" that the above copyright notice appear in all copies. Karl Lehenbauer and .\" Mark Diekhans make no representations about the suitability of this .\" software for any purpose. It is provided "as is" without express or .\" implied warranty. .\"---------------------------------------------------------------------------- .\" $Id: TclX.n,v 8.23 2004/11/22 21:58:20 hobbs Exp $ .\"---------------------------------------------------------------------------- .\" .TH "TclX" TCL "" "Tcl" .ad b .SH NAME TclX \- Extended Tcl: Extended command set for Tcl ' .SH SYNOPSIS \fBpackage require Tclx\fR .PP .SH "INTRODUCTION" .PP This man page contains the documentation for all of the extensions that are added to Tcl by Extended Tcl (TclX). TclX extends Tcl's capabilities by adding new commands to it, without changing the syntax of standard Tcl. Extended Tcl is a superset of standard Tcl and is built alongside the standard Tcl sources. .PP Extended Tcl was created by Karl Lehenbauer and Mark Diekhans and is freely redistributable for any use without license or fee. .PP Available since 1989, Extended Tcl, also known as TclX, not only adds capabilities to Tcl, but has also been the source of many of the capabilities of the baseline Tcl release, including arrays, files, sockets, file events, and date and time handling, among others. .PP Extended Tcl introduces a set of new commands and a user-extensible library of useful Tcl procedures, any of which can be automatically loaded on the first attempt to execute it. .PP The command descriptions are separated into several sections: .RS 5 .TP \(bu General Commands .TP \(bu Debugging and Development Commands .TP \(bu Unix Access Commands .TP \(bu File Commands .TP \(bu Network Programming Support .TP \(bu File Scanning Commands .TP \(bu Math Commands .TP \(bu List Manipulation Commands .TP \(bu Keyed Lists .TP \(bu String and Character Manipulation Commands .TP \(bu XPG/3 Message Catalog Commands .TP \(bu Help Facility .TP \(bu Tcl Loadable Libraries and Packages .RE ' .bp .SH "GENERAL COMMANDS" .PP A set of general, useful Tcl commands, includes a command to begin an interactive session with Tcl, a facility for tracing execution, and a looping command. ' '\"@help: tcl/status/dirs '\"@brief: List the directories in the directory stack. .TP \fBdirs\fR This procedure lists the directories in the directory stack. '\"@: '\"@:This procedure is provided by Extended Tcl. '\"@endhelp ' '\"@help: tcl/control/commandloop '\"@brief: Create an interactive command loop or event based command reader. .TP \fBcommandloop \fR?\fB\-async\fR? ?\fB\-interactive \fBon | off | tty\fR? ?\fB\-prompt1 \fIcmd\fR? ?\fB\-prompt2 \fIcmd\fR? ?\fB\-endcommand \fIcmd\fR? .IP Create an interactive command loop reading commands from stdin and writing results to stdout. Command loops are maybe either be blocking or event oriented. This command is useful for Tcl scripts that do not normally converse interactively with a user through a Tcl command interpreter, but which sometimes want to enter this mode, perhaps for debugging or user configuration. The command loop terminates on EOF. .IP The following options are available: .RS .TP \fB\-async\fR A command handler will be associated with stdin. When input is available on stdin, it will be read and accumulated until a full command is available. That command will then be evaluated. An event loop must be entered for input to be read and processed. ' .TP \fB\-interactive on | off | tty\fR Enable or disable interactive command mode. In interactive mode, commands are prompted for and the results of comments are printed. The value maybe any boolean value or \fBtty\fR. If \fBtty\fR is used, interactive mode is enabled if stdin is associated with a terminal or terminal emulator. The default is \fBtty\fR. ' .TP \fB\-prompt1 \fIcmd\fR If specified, \fIcmd\fR is used is evaluate and its result used for the main command prompt. If not specified, the command in \fBtcl_prompt1\fR is evaluated to output the prompt. Note the difference in behavior, \fIcmd\fR results is used, while \fBtcl_prompt1\fR outputs. This is to allow for future expansion to command loops that write to other than stdout. ' .TP \fB\-prompt2 \fIcmd\fR If specified, \fIcmd\fR is used is evaluate and its result used for the secondary (continuation) command prompt. If not specified, the command in \fBtcl_prompt2\fR is evaluated to output the prompt. ' .TP \fB\-endcommand \fIcmd\fR If specified, \fIcmd\fR is evaluated when the command loop terminates. .IP In interactive mode, the results of set commands with two arguments are not printed. .IP If \fBSIGINT\fR is configured to generate a Tcl error, it can be used to delete the current command being type without aborting the program in progress. .RE '\"@: '\"@:This command is provided by Extended Tcl. '\"@endhelp ' '\"@help: tcl/files/echo '\"@brief: Echo one or more strings to stdout, followed by a newline. .TP \fBecho \fR?\fIstr ...\fR? Writes zero or more strings to standard output, followed by a newline. '\"@: '\"@:This command is provided by Extended Tcl. '\"@endhelp ' '\"@help: tcl/status/infox '\"@brief: Return information about Extended Tcl, or the current application. .TP \fBinfox\fR \fIoption\fR .IP Return information about Extended Tcl, or the current application. The following \fBinfox\fR command options are available: .RS .TP \fBversion\fR Return the version number of Extended Tcl. The version number for Extended Tcl is generated by combining the base version of the standard Tcl code with another number indicating the version of Extended Tcl being used. .TP \fBpatchlevel\fR Return the patchlevel for Extended Tcl. .TP \fBhave_fchown\fR Return \fB1\fR if the \fBfchown\fR system call is available. This supports the \fB\-fileid\fR option on the \fBchown\fR and \fBchgrp\fR commands. .TP \fBhave_fchmod\fR Return \fB1\fR if the \fBfchmod\fR system call is available. This supports the \fB\-fileid\fR option on the \fBchmod\fR command. .TP \fBhave_flock\fR Return \fB1\fR if the \fBflock\fR command defined, \fB0\fR if it is not available. .TP \fBhave_fsync\fR Return \fB1\fR if the \fBfsync\fR system call is available and the \fBsync\fR command will sync individual files. \fB0\fR if it is not available and the \fBsync\fR command will always sync all file buffers. .TP \fBhave_ftruncate\fR Return \fB1\fR if the \fBftruncate\fR or \fBchsize\fR system call is available. If it is, the \fBftruncate\fR command \fB\-fileid\fR option maybe used. .TP \fBhave_msgcats\fR Return \fB1\fR if XPG message catalogs are available, \fB0\fR if they are not. The \fBcatgets\fR is designed to continue to function without message catalogs, always returning the default string. .TP \fBhave_posix_signals\fR Return \fB1\fR if Posix signals are available (\fBblock\fR and \fBunblock\fR options available for the signal command). \fB0\fR is returned if Posix signals are not available. .TP \fBhave_signal_restart\fR Return \fB1\fR if restartable signals are available (\fB-restart\fR option available for the signal command). \fB0\fR is returned if restartable signals are not available. .TP \fBhave_truncate\fR Return \fB1\fR if the \fBtruncate\fR system call is available. If it is, the \fBftruncate\fR command may truncate by file path. .TP \fBhave_waitpid\fR Return \fB1\fR if the \fBwaitpid\fR system call is available and the \fBwait\fR command has full functionality. \fB0\fR if the \fBwait\fR command has limited functionality. .TP \fBappname\fR Return the symbolic application name of the current application linked with the Extended Tcl library. The C variable \fBtclAppName\fR must be set by the application to return an application specific value for this variable. .TP \fBapplongname\fR Return a natural language name for the current application. The C variable \fBtclLongAppName\fR must be set by the application to return an application specific value for this variable. .TP \fBappversion\fR Return the version number for the current application. The C variable \fBtclAppVersion\fR must be set by the application to return an application-specific value for this variable. .TP \fBapppatchlevel\fR Return the patchlevel for the current application. The C variable \fBtclAppPatchlevel\fR must be set by the application to return an application-specific value for this variable. .RE '\"@: '\"@:This command is provided by Extended Tcl. '\"@endhelp ' '\"@help: tcl/variables/for_array_keys '\"@brief: Do a foreach-style loop on each key in an array. .TP \fBfor_array_keys\fR \fIvar array_name code\fR This procedure performs a foreach-style loop for each key in the named array. The \fBbreak\fR and \fBcontinue\fR statements work as with \fBforeach\fR. '\"@: '\"@:This procedure is provided by Extended Tcl. '\"@endhelp ' '\"@help: tcl/files/for_recursive_glob '\"@brief: A foreach-style loop for all matched (globbed) files. .TP \fBfor_recursive_glob\fR \fIvar dirlist globlist code\fR This procedure performs a foreach-style loop over recursively matched files. All directories in \fIdirlist\fR are recursively searched (breadth-first), comparing each file found against the file glob patterns in \fBgloblist\fR. For each matched file, the variable \fIvar\fR is set to the file path and \fIcode\fR is evaluated. Symbolic links are not followed. '\"@: '\"@:This procedure is provided by Extended Tcl. '\"@endhelp ' '\"@help: tcl/control/loop '\"@brief: Higher-performance for-style loop. .TP \fBloop\fR \fIvar first limit ?increment? body\fR \fBLoop\fR is a looping command, similar in behavior to the Tcl \fBfor\fR statement, except that the \fBloop\fR statement achieves substantially higher performance and is easier to code when the beginning and ending values of a loop are known, and the loop variable is to be incremented by a known, fixed amount every time through the loop. .sp The \fIvar\fR argument is the name of a Tcl variable that will contain the loop index. The loop index is set to the value specified by \fIfirst\fR. The Tcl interpreter is invoked upon \fIbody\fR zero or more times, where \fIvar\fR is incremented by \fIincrement\fR every time through the loop, or by one if \fIincrement\fR is not specified. \fIIncrement\fR can be negative in which case the loop will count downwards. .sp When \fIvar\fR reaches \fIlimit\fR, the loop terminates without a subsequent execution of \fIbody\fR. For instance, if the original \fBloop\fR parameters would cause \fBloop\fR to terminate, say \fIfirst\fR was one, \fIlimit\fR was zero and \fIincrement\fR was not specified or was non-negative, \fIbody\fR is not executed at all and \fBloop\fR returns. .sp The \fIfirst\fR, \fIlimit\fR and \fIincrement\fR are integer expressions. They are only evaluated once at the beginning of the loop. .sp If a \fBcontinue\fR command is invoked within \fIbody\fR then any remaining commands in the current execution of \fIbody\fR are skipped, as in the \fBfor\fR command. If a \fBbreak\fR command is invoked within \fIbody\fR then the \fBloop\fR command will return immediately. \fBLoop\fR returns an empty string. '\"@: '\"@:This command is provided by Extended Tcl. '\"@endhelp ' '\"@help: tcl/status/popd '\"@brief: Pop a directory from a stack of directories and cd to it. .TP \fBpopd\fR This procedure pops the top directory entry from the directory stack and make it the current directory. '\"@: '\"@:This procedure is provided by Extended Tcl. '\"@endhelp ' '\"@help: tcl/status/pushd '\"@brief: Push a directory to a stack of directories. .TP \fBpushd\fR ?\fIdir\fR? This procedure pushes the current directory onto the directory stack and \fBcd\fR to the specified directory. If the directory is not specified, then the current directory is pushed, but remains unchanged. '\"@: '\"@:This procedure is provided by Extended Tcl. '\"@endhelp ' '\"@help: tcl/files/recursive_glob '\"@brief: Recursive filename matching (globbing). .TP \fBrecursive_glob\fR \fIdirlist globlist\fR This procedure returns a list of recursively matches files. All directories in \fIdirlist\fR are recursively searched (breadth-first), comparing each file found against the file glob patterns in \fBgloblist\fR. Symbolic links are not followed. '\"@: '\"@:This procedure is provided by Extended Tcl. '\"@endhelp ' '\"@help: tcl/status/showproc '\"@brief: List the definition of the named procedure. .TP \fBshowproc \fR?\fIprocname ...?\fR This procedure lists the definition of the named procedures. Loading them if it is not already loaded. If no procedure names are supplied, the definitions of all currently loaded procedures are returned. '\"@: '\"@:This procedure is provided by Extended Tcl. '\"@endhelp ' '\"@help: tcl/control/try_eval '\"@brief: Evaluate commands with error catch and finalization. .TP \fBtry_eval\fR \fIcode\fR \fIcatch\fR ?\fIfinally\fR? The \fBtry_eval\fR command evaluates \fIcode\fR in the current context. .P If an error occurs during the evaluation and \fIcatch\fR is not empty, then \fIcatch\fR is evaluated to handler the error. The result of the command, containing the error message, will be stored in a global variable \fBerrorResult\fR. The global variables \fBerrorResult\fR, \fBerrorInfo\fR and \fBerrorCode\fR will be imported into the current scope, there is no need to execute a \fBglobal\fR command. The result of the \fIcatch\fR command becomes the result of the \fBtry_eval\fR command. If the error that caused the \fIcatch\fR to be evaluate is to be continued, the following command should be used: .br .nf \fBerror $errorResult $errorCode $errorInfo\fR .fi .br .P If the \fIfinally\fR argument is supplied and not empty, it is evaluated after the evaluation of the \fIcode\fR and the \fIcatch\fR commands. If an error occurs during the evaluation of the \fIfinally\fR command, it becomes the result of the \fBtry_eval\fR command. Otherwise, the result of either \fIcode\fR or \fIcatch\fR is preserved, as described above. '\"@: '\"@:This command is provided by Extended Tcl. '\"@endhelp ' .bp .SH "DEBUGGING AND DEVELOPMENT COMMANDS" This section contains information on commands and procedures that are useful for developing and debugging Tcl scripts. '\"@help: tcl/debug/cmdtrace '\"@brief: Trace Tcl execution. .TP \fBcmdtrace\fR \fIlevel\fR | \fBon\fR ?\fBnoeval\fR? ?\fBnotruncate\fR? ?\fIprocs\fR? ?\fIfileid\fR? ?\fBcommand\fI cmd\fR? .IP Print a trace statement for all commands executed at depth of \fIlevel\fR or below (1 is the top level). If \fBon\fR is specified, all commands at any level are traced. The following options are available: .RS .TP \fBnoeval\fR Causes arguments to be printed unevaluated. If \fBnoeval\fR is specified, the arguments are printed before evaluation. Otherwise, they are printed afterwards. .sp If the command line is longer than 60 characters, it is truncated to 60 and a "..." is postpended to indicate that there was more output than was displayed. If an evaluated argument contains a space, the entire argument will be enclosed inside of braces (`{}') to allow the reader to visually separate the arguments from each other. .TP \fBnotruncate\fR Disables the truncation of commands and evaluated arguments. .TP \fBprocs\fR Enables the tracing of procedure calls only. Commands that aren't procedure calls (i.e. calls to commands that are written in C, C++ or some object-compatible language) are not traced if the \fBprocs\fR option is specified. This option is particularly useful for greatly reducing the output of \fBcmdtrace\fR while debugging. .TP \fBfileid\fR This is a file id as returned by the \fBopen\fR command. If specified, then the trace output will be written to the file rather than stdout. A stdio buffer flush is done after every line is written so that the trace may be monitored externally or provide useful information for debugging problems that cause core dumps. .TP \fBcommand\fR \fIcmd\fR .IP Call the specified command \fIcmd\fR on when each command is executed instead of tracing to a file. See the description of the functionally below. This option may not be specified with a \fBfileid\fR. .RE .IP The most common use of this command is to enable tracing to a file during the development. If a failure occurs, a trace is then available when needed. Command tracing will slow down the execution of code, so it should be removed when code is debugged. The following command will enable tracing to a file for the remainder of the program: .IP .nf .ft CW cmdtrace on [open cmd.log w] .ft R .fi .IP The \fBcommand\fR option causes a user specified trace command to be called for each command executed. The command will have the following arguments appended to it before evaluation: .RS .IP "\fIcommand\fR" A string containing the text of the command, before any argument substitution. .IP "\fIargv\fR" A list of the final argument information that will be passed to the command after command, variable, and backslash substitution. .IP "\fIevalLevel\fR" The \fBTcl_Eval\fR call level. .IP "\fIprocLevel\fR" The procedure call level. .RE .IP The command should be constructed in such a manner that it will work if additional arguments are added in the future. It is suggested that the command be a \fBproc\fR with the final argument being \fBargs\fR. .IP Tracing will be turned off while the command is being executed. The values of the \fBerrorInfo\fR and \fBerrorCode\fR variables will be saved and restored on return from the command. It is the command's responsibility to preserve all other state. .IP If an error occurs during the execution of \fBcommand\fR, an error message is dumped to \fRstderr\fR and the tracing is disabled. The underlying mechanism that this functionality is built on does not support returning an error to the interpreter. .TP \fBcmdtrace off\fR Turn off all tracing. .TP \fBcmdtrace depth\fR Returns the current maximum trace level, or zero if trace is disabled. '\"@: '\"@:This command is provided by Extended Tcl. '\"@endhelp ' '\"@help: tcl/debug/edprocs '\"@brief: Edit named procs, or all procs. .TP \fBedprocs \fR?\fIproc\fR...? This procedure writes the named procedures, or all currently defined procedures, to a temporary file, then calls an editor on it (as specified by the \fBEDITOR\fR environment variable, or \fBvi\fR if none is specified), then sources the file back in if it was changed. '\"@: '\"@:This procedure is provided by Extended Tcl. '\"@endhelp ' '\"@help: tcl/debug/profile '\"@brief: Collect Tcl script performance profile data. .TP \fBprofile\fR ?\fI\-commands\fR? ?\fI\-eval\fR? \fBon\fR .TP \fBprofile off\fR \fIarrayVar\fR This command is used to collect a performance profile of a Tcl script. It collects data at the Tcl procedure level. The number of calls to a procedure, and the amount of real and CPU time is collected. Time is also collected for the global context. The procedure data is collected by bucketing it based on the procedure call stack, this allows determination of how much time is spent in a particular procedure in each of it's calling contexts. .sp The \fBon\fR option enables profile data collection. If the \fB\-commands\fR option is specified, data on all commands within a procedure is collected as well a procedures. Multiple occurrences of a command within a procedure are not distinguished, but this data may still be useful for analysis. .sp The \fBoff\fR option turns off profiling and moves the data collected to the array \fIarrayVar\fR. The array is address by a list containing the procedure call stack. Element zero is the top of the stack, the procedure that the data is for. The data in each entry is a list consisting of the procedure call count and the real time and CPU time in milliseconds spent in the procedure (but not any procedures it calls). The list is in the form {\fIcount real cpu\fR}. .sp Normally, the variable scope stack is used in reporting where time is spent. Thus upleveled code is reported in the context that it was executed in, not the context that the uplevel was called in. If the \fB\-eval\fR option is specified, the procedure evaluation (call) stack is used instead of the procedure scope stack. Upleveled code is reported in the context of the procedure that did the uplevel. .sp A Tcl procedure \fBprofrep\fR is supplied for reducing the data and producing a report. .sp On \fBWindows\fR, profile command only reports elapsed real time, CPU time is not available and is reported as zero. '\"@: '\"@:This command is provided by Extended Tcl. '\"@endhelp ' '\"@help: tcl/debug/profrep '\"@brief: Generate a report from data collect from the profile command. .TP \fBprofrep\fR \fIprofDataVar sortKey\fR ?\fIoutFile\fR? ?\fIuserTitle\fR? This procedure generates a report from data collect from the profile command. \fBProfDataVar\fR is the name of the array containing the data returned by the \fBprofile\fR command. \fBSortKey\fR indicates which data value to sort by. It should be one of "\fBcalls\fR", "\fBcpu\fR" or "\fBreal\fR". \fBOutFile\fR is the name of file to write the report to. If omitted, stdout is assumed. \fBUserTitle\fR is an optional title line to add to output. .IP Listed with indentation below each procedure or command is the procedure call stack. The first indented line being the procedure that invoked the reported procedure or command. The next line is the procedure that invoked the procedure above it, and so on. If no indented procedures are shown, the procedure or command was called from the global context. Time actually spent in the global context is listed on a line labeled \fB\fR. Upleveled code is reported in the context that it was executed in, not the context that the uplevel was called in. '\"@: '\"@:This procedure is provided by Extended Tcl. '\"@endhelp ' '\"@help: tcl/debug/saveprocs '\"@brief: Save named procs to a file, or all procs. .TP \fBsaveprocs\fR \fIfileName\fR ?\fIproc\fR...? This procedure saves the definition of the named procedure, or all currently defined procedures if none is specified, to the named file. '\"@: '\"@:This procedure is provided by Extended Tcl. '\"@endhelp ' .bp .SH "UNIX ACCESS COMMANDS" .PP These commands provide access to many basic Unix facilities, including process handling, date and time processing, signal handling and the executing commands via the shell. ' '\"@help: tcl/time/alarm '\"@brief: Set a process alarm clock. .TP \fBalarm\fR \fIseconds\fR Instructs the system to send a SIGALRM signal in the specified number of seconds. This is a floating point number, so fractions of a section may be specified. If \fIseconds\fR is 0.0, any previous alarm request is canceled. Only one alarm at a time may be active; the command returns the number of seconds left in the previous alarm. On systems without the \fBsetitimer\fR system call, \fIseconds\fR is rounded up to an integer number of seconds. .sp The \fBalarm\fR command is not available on \fBWindows\fR. '\"@: '\"@:This command is provided by Extended Tcl. '\"@endhelp ' '\"@help: tcl/processes/execl '\"@brief: Perform a process exec, executing a file. .TP \fBexecl \fR?\fB\-argv0\fR argv0\fR? \fIprog\fR ?\fIarglist\fR? Do an execl, replacing the current program (either Extended Tcl or an application with Extended Tcl embedded into it) with \fIprog\fR and passing the arguments in the list \fIarglist\fR. .sp The \fB\-argv0\fR options specifies that \fIargv0\fR is to be passed to the program as argv [0] rather than \fIprog\fR. .sp Note: If you are using \fBexecl\fR in a Tk application and it fails, you may not do anything that accesses the X server or you will receive a \fBBadWindow\fR error from the X server. This includes executing the Tk version of the \fBexit\fR command. We suggest using the following command to abort Tk applications after an \fBexecl\fR failure: .sp .nf .ft CW kill [id process] .ft R .fi .sp On \fBWindows\fR, where the \fBfork\fR command is not available, \fBexecl\fR starts a new process and returns the process id. '\"@: '\"@:This command is provided by Extended Tcl. '\"@endhelp ' '\"@help: tcl/files/chroot '\"@brief: Change root directory. .TP \fBchroot\fR \fIdirname\fR Change root directory to \fIdirname\fR, by invoking the POSIX \fBchroot(2)\fR system call. This command only succeeds if running as root. '\"@: '\"@:This command is provided by Extended Tcl. '\"@endhelp ' '\"@help: tcl/processes/fork '\"@brief: Fork the current Tcl process. .TP \fBfork\fR Fork the current Tcl process. Fork returns zero to the child process and the process number of the child to the parent process. If the fork fails, a Tcl error is generated. .sp If an \fBexecl\fR is not going to be performed before the child process does output, or if a \fBclose\fR and \fBdup\fR sequence is going to be performed on \fBstdout\fR or \fBstderr\fR, then a \fBflush\fR should be issued against \fBstdout\fR, \fBstderr\fR and any other open output file before doing the \fBfork\fR. Otherwise characters from the parent process pending in the buffers will be output by both the parent and child processes. .sp Note: If you are \fBfork\fRing in a Tk based application you must \fBexecl\fR before doing any window operations in the child or you will receive a \fBBadWindow\fR error from the X server. .sp The \fBfork\fR command is not available on \fBWindows\fR. '\"@: '\"@:This command is provided by Extended Tcl. '\"@endhelp ' '\"@help: tcl/status/id '\"@brief: Access, set or convert process, user and group information. .TP \fBid options\fR .IP This command provides a means of getting, setting and converting user, group and process ids. The \fBid\fR command has the following options: ' .RS .TP \fBid user \fR?\fIname\fR? .TP \fBid userid \fR?\fIuid\fR? Set the real and effective user ID to \fIname\fR or \fIuid\fR, if the name (or uid) is valid and permissions allow it. If the name (or uid) is not specified, the current name (or uid) is returned. .TP \fBid convert userid\fR \fIuid\fR .TP \fBid convert user\fR \fIname\fR Convert a user ID number to a user name, or vice versa. .TP \fBid group \fR?\fIname\fR? .TP \fBid groupid \fR?\fIgid\fR? Set the real and effective group ID to \fIname\fR or \fIgid\fR, if the name (or gid) is valid and permissions allow it. If the group name (or gid) is not specified, the current group name (or gid) is returned. .TP \fBid groups\fR .TP \fBid groupids\fR Return the current group access list of the process. The option \fBgroups\fR returns group names and \fBgroupids\fR returns id numbers. .TP \fBid convert groupid\fR \fIgid\fR .TP \fBid convert group\fR \fIname\fR Convert a group ID number to a group name, or vice versa. .TP \fBid effective user\fR .TP \fBid effective userid\fR Return the effective user name, or effective user ID number, respectively. .TP \fBid effective group\fR .TP \fBid effective groupid\fR Return the effective group name, or effective group ID number, respectively. .TP \fBid effective groupids\fR Return all of the groupids the user is a member of. .TP \fBid host\fR Return the hostname of the system the program is running on. .TP \fBid process\fR Return the process ID of the current process. .TP \fBid process parent\fR Return the process ID of the parent of the current process. .TP \fBid process group\fR Return the process group ID of the current process. .TP \fBid process group set\fR Set the process group ID of the current process to its process ID. .TP \fBid host\fR Returns the standard host name of the machine the process is executing on. .IP On \fBWindows\fR, only the \fBhost\fR and \fBprocess\fR options are implemented. .RE '\"@: '\"@:This command is provided by Extended Tcl. '\"@endhelp ' '\"@help: tcl/processes/kill '\"@brief: Send a signal to the specified process. .TP \fBkill\fR ?\fB\-pgroup\fR ?\fIsignal\fR? \fIidlist\fR .IP Send a signal to the each process in the list \fIidlist\fR, if permitted. \fISignal\fR, if present, is the signal number or the symbolic name of the signal, see the signal system call manual page. The leading ``SIG'' is optional when the signal is specified by its symbolic name. The default for \fIsigno\fR is 15, SIGTERM. .IP If \fB\-pgroup\fR is specified, the numbers in \fIidlist\fR are take as process group ids and the signal is sent to all of the process in that process group. A process group id of \fB0\fR specifies the current process group. .IP On \fBWindows\fR, the \fBkill\fR command is capable of terminating a process, but not of sending an arbitrary signal. '\"@: '\"@:This command is provided by Extended Tcl. '\"@endhelp ' '\"@help: tcl/files/link '\"@brief: Create a link to a file. .TP \fBlink\fR ?\fB\-sym\fR? \fIsrcpath destpath\fR .IP Create a directory entry, \fIdestpath\fR, linking it to the existing file, \fIsrcpath\fR. If \fB\-sym\fR is specified, a symbolic link, rather than a hard link, is created. (The \fB\-sym\fR option is only available on systems that support symbolic links.) .IP The \fBlink\fR command is not available on \fBWindows\fR. Use the Tcl 8.4+ \fBfile link\fR command instead. '\"@: '\"@:This command is provided by Extended Tcl. '\"@endhelp ' '\"@help: tcl/processes/nice '\"@brief: Change or return the process priority. .TP \fBnice \fR?\fIpriorityincr\fR? .IP Change or return the process priority. If \fIpriorityincr\fR is omitted, the current priority is returned. If \fIpriorityincr\fR is positive, it is added to the current \fIpriority\fR level, up to a system defined maximum (normally \fB19\fR), .IP Negative \fIpriorityincr\fR values cumulatively increase the program's priority down to a system defined minimum (normally \fB\-19\fR); increasing priority with negative niceness values will only work for the superuser. .IP The new priority is returned. .IP The \fBnice\fR command is not available on \fBWindows\fR. '\"@: '\"@:This command is provided by Extended Tcl. '\"@endhelp ' '\"@help: tcl/files/readdir '\"@brief: Read the contents of a directory. .TP \fBreaddir\fR ?\fI\-hidden\fR? \fIdirPath\fR .IP Returns a list containing the contents of the directory \fIdirPath\fR. The directory entries "." and ".." are not returned. .IP On \fBWindows\fR, \fB\-hidden\fR maybe specified to include hidden files in the result. This flag is ignored on Unix systems. '\"@: '\"@:This command is provided by Extended Tcl. '\"@endhelp ' '\"@help: tcl/signals/signal '\"@brief: Specify action to take when a signal is received. .TP \fBsignal\fR ?\fI\-restart\fR? \fIaction\fR \fIsiglist\fR ?\fIcommand\fR? .IP Warning: If signals are being used as an event source (a \fBtrap\fR action), rather than generating an error to terminate a task; one must use the \fB-restart\fR option. This causes a blocked system call, such as \fBread\fR or \fBwaitpid\fR to be restarted rather than generate an error. Failure to do this may results in unexpected errors when a signal arrives while in one of these system calls. When available, the \fB-restart\fR option can prevent this problem. .IP If \fB-restart\fR is specified, restart blocking system calls rather than generating an error. The signal will be handled once the Tcl command that issued the system call completes. The \fB-restart\fR options is not available on all operating systems and its use will generate an error when it is not supported. Use \fBinfox have_signal_restart\fR to check for availability. .IP Specify the action to take when a Unix signal is received by Extended Tcl, or a program that embeds it. \fISiglist\fR is a list of either the symbolic or numeric Unix signal (the SIG prefix is optional). \fIAction\fR is one of the following actions to be performed on receipt of the signal. To specify all modifiable signals, use `*' (this will not include SIGKILL and SIGSTOP, as they can not be modified). .RS .IP "\fBdefault\fR" Perform system default action when signal is received (see \fBsignal\fR system call documentation). .IP "\fBignore\fR" Ignore the signal. .IP "\fBerror\fR" Generate a catchable Tcl error. It will be as if the command that was running returned an error. The error code will be in the form: .br .nf \fBPOSIX SIG\fR \fIsigname\fR .fi .br For the death of child signal, \fIsigname\fR will always be SIGCHLD, rather than SIGCLD, to allow writing portable code. .IP "\fBtrap\fR" When the signal occurs, execute \fIcommand\fR and continue execution if an error is not returned by \fIcommand\fR. The command will be executed in the global context. The command will be edited before execution, replacing occurrences of "%S" with the signal name. Occurrences of "%%" result in a single "%". This editing occurs just before the trap command is evaluated. If an error is returned, then follow the standard Tcl error mechanism. Often \fIcommand\fR will just do an \fBexit\fR. .IP "\fBget\fR" Retrieve the current settings of the specified signals. A keyed list will be returned were the keys are one of the specified signals and the values are a list consisting of the action associated with the signal, a \fB0\fR if the signal may be delivered (not block) and a \fB1\fR if it is blocked and a flag indicating if restarting of system calls is specified. The actions maybe one of `\fBdefault\fR',`\fBignore\fR', `\fBerror\fR' or `\fBtrap\fR'. If the action is trap, the third element is the command associated with the action. The action `\fBunknown\fR' is returned if a non-Tcl signal handler has been associated with the signal. .IP "\fBset\fR" Set signals from a keyed list in the format returned by the \fBget\fR. For this action, \fIsiglist\fR is the keyed list of signal state. Signals with an action of `\fBunknown\fR' are not modified. .IP "\fBblock\fR" Block the specified signals from being received. (Posix systems only). .IP "\fBunblock\fR" Allow the specified signal to be received. Pending signals will not occur. (Posix systems only). .RE .IP The signal action will remain enabled after the specified signal has occurred. The exception to this is \fBSIGCHLD\fR on systems without Posix signals. For these systems, \fBSIGCHLD\fR is not be automatically reenabled. After a \fBSIGCHLD\fR signal is received, a call to \fBwait\fR must be performed to retrieve the exit status of the child process before issuing another \fBsignal SIGCHLD \fI...\fR command. For code that is to be portable between both types of systems, use this approach. .IP Signals are not processed until after the completion of the Tcl command that is executing when the signal is received. If an interactive Tcl shell is running, then the \fBSIGINT\fR will be set to \fBerror\fR, non-interactive Tcl sessions leave \fBSIGINT\fR unchanged from when the process started (normally \fBdefault\fR for foreground processes and \fBignore\fR for processes in the background). '\"@: '\"@:This command is provided by Extended Tcl. '\"@endhelp ' '\"@help: tcl/time/sleep '\"@brief: Sleep for the specified number of seconds. .TP \fBsleep\fR \fIseconds\fR .br Sleep the Extended Tcl process for \fIseconds\fR seconds. \fISeconds\FR, if specified as a decimal number, is truncated to an integer value. '\"@: '\"@:This command is provided by Extended Tcl. '\"@endhelp ' '\"@help: tcl/processes/system '\"@brief: Execute command via `system' call. .TP \fBsystem\fR \fIcmdstr1\fR ?\fIcmdstr2\fR...? .br Concatenates \fIcmdstr1\fR, \fIcmdstr2\fR etc with space separators (see the \fBconcat\fR command) into a single command and then evaluates the command using the standard system shell. On Unix systems, this is \fB/bin/sh\fR and on Windows its \fBcommand.com\fR. The exit code of the command is returned. .sp This command differs from the \fBexec\fR command in that \fBsystem\fR doesn't return the executed command's standard output as the result string, and \fBsystem\fR goes through the Unix shell to provide wild card expansion, redirection, etc, as is normal from an \fBsh\fR command line. '\"@: '\"@:This command is provided by Extended Tcl. '\"@endhelp ' '\"@help: tcl/files/sync '\"@brief: Force a file or all files to be written to disk. .TP \fBsync \fR?\fIfileId\fR? .IP If \fIfileId\fR is not specified, or if it is and this system does not support the \fIfsync\fR system call, issues a \fIsync\fR system call to flush all pending disk output. If \fIfileId\fR is specified and the system does support the \fIfsync\fR system call, issues an \fIfsync\fR on the file corresponding to the specified Tcl \fIfileId\fR to force all pending output to that file out to the disk. .IP If \fIfileId\fR is specified, the file must be writable. A \fBflush\fR will be issued against the \fIfileId\fR before the sync. .IP The \fIinfox have_fsync\fR command can be used to determine if "\fBsync\fR \fIfileId\fR" will do a \fIsync\fR or a \fIfsync\fR. '\"@: '\"@:This command is provided by Extended Tcl. '\"@endhelp ' '\"@help: tcl/time/times '\"@brief: Get process and child execution times. .TP \fBtimes\fR .br Return a list containing the process and child execution times in the form: .br .nf \fIutime stime cutime cstime\fR .fi .br Also see the \fItimes\fR(2) system call manual page. The values are in milliseconds. '\"@: '\"@:This command is provided by Extended Tcl. '\"@endhelp ' '\"@help: tcl/status/umask '\"@brief: Get or set the file-creation mode mask. .TP \fBumask \fR?\fIoctalmask\fR? .br Sets file-creation mode mask to the octal value of \fIoctalmask\fR. If \fIoctalmask\fR is omitted, the current mask is returned. '\"@: '\"@:This command is provided by Extended Tcl. '\"@endhelp ' '\"@help: tcl/processes/wait '\"@brief: Wait for a child process to terminate. .TP \fBwait \fR?\fB\-nohang\fR? ?\fB\-untraced\fR? ?\fB\-pgroup\fR? ?\fIpid\fR? .br Waits for a process created with the \fBexecl\fR command to terminate, either due to an untrapped signal or call to \fIexit\fR system call. If the process id \fIpid\fR is specified, they wait on that process, otherwise wait on any child process to terminate. .sp If \fB\-nohang\fR is specified, then don't block waiting on a process to terminate. If no process is immediately available, return an empty list. If \fB\-untraced\fR is specified then the status of child processes that are stopped, and whose status has not yet been reported since they stopped, are also returned. If \fB\-pgroup\fR is specified and \fIpid\fR is not specified, then wait on any child process whose process group ID is they same as the calling process. If \fIpid\fR is specified with \fB\-pgroup\fR, then it is take as a process group ID, waiting on any process in that process group to terminate. .sp \fBWait\fR returns a list containing three elements: The first element is the process id of the process that terminated. If the process exited normally, the second element is `EXIT', and the third contains the numeric exit code. If the process terminated due to a signal, the second element is `SIG', and the third contains the signal name. If the process is currently stopped (on systems that support SIGSTP), the second element is `STOP', followed by the signal name. .sp Note that it is possible to wait on processes to terminate that were create in the background with the \fBexec\fR command. However, if any other \fBexec\fR command is executed after the process terminates, then the process status will be reaped by the \fBexec\fR command and will not be available to the \fBwait\fR command. .sp On systems without the \fBwaitpid\fR system call, the \fB\-nohang\fR, \fB\-untraced\fR and \fB\-pgroup\fR options are not available. The \fBinfox have_waitpid\fR command maybe use to determine if this functionality is available. '\"@: '\"@:This command is provided by Extended Tcl. '\"@endhelp ' .bp .SH "FILE COMMANDS" .PP These commands provide extended file access and manipulation. This includes searching ASCII-sorted data files, copying files, duplicating file descriptors, control of file access options, retrieving open file status, and creating pipes with the \fBpipe\fR system call. Also linking files, setting file, process, and user attributes and truncating files. An interface to the \fBselect\fR system call is available on Unix systems that support it. .PP It should be noted that Tcl file I/O is implemented on top of the stdio library. By default, the file is buffered. When communicating to a process through a pipe, a \fBflush\fR command should be issued to force the data out. Alternatively, the \fBfcntl\fR command may be used to set the buffering mode of a file to line-buffered or unbuffered. ' '\"@help: tcl/files/bsearch .TP \fBbsearch\fR \fIfileId key\fR ?\fIretvar\fR? ?\fIcompare_proc\fR? .br Search an opened file \fIfileId\fR containing lines of text sorted into ascending order for a match. \fIKey\fR contains the string to match. If \fIretvar\fR is specified, then the line from the file is returned in \fIretvar\fR, and the command returns \fB1\fR if \fIkey\fR was found, and \fB0\fR if it wasn't. If \fIretvar\fR is not specified or is a null name, then the command returns the line that was found, or an empty string if \fIkey\fR wasn't found. .sp By default, the key is matched against the first white-space separated field in each line. The field is treated as an ASCII string. If \fIcompare_proc\fR is specified, then it defines the name of a Tcl procedure to evaluate against each line read from the sorted file during the execution of the \fBbsearch\fR command. \fICompare_proc\fR takes two arguments, the key and a line extracted from the file. The compare routine should return a number less than zero if the key is less than the line, zero if the key matches the line, or greater than zero if the key is greater than the line. The file must be sorted in ascending order according to the same criteria \fIcompare_proc\fR uses to compare the key with the line, or erroneous results will occur. .sp This command does not work on files containing binary data (bytes of zero). '\"@: '\"@:This command is provided by Extended Tcl. '\"@endhelp ' '\"@help: tcl/files/chmod '\"@brief: Set file permissions. .TP \fBchmod \fR[\fB\-fileid\fR] \fImode\fR \fIfilelist\fR .br Set permissions of each of the files in the list \fIfilelist\fR to \fImode\fR, where \fImode\fR is an absolute numeric mode or symbolic permissions as in the UNIX \fBchmod(1)\fR command. To specify a mode as octal, it should be prefixed with a "0" (e.g. 0622). .sp If the option \fB\-fileid\fR is specified, \fIfilelist\fR is a list of open file identifiers rather than a list of file names. This option is not available on all Unix systems. Use the \fBinfox have_fchmod\fR command to determine if this functionality is available. .sp The \fBchmod\fR command is not available on \fBWindows\fR. '\"@: '\"@:This command is provided by Extended Tcl. '\"@endhelp ' '\"@help: tcl/files/chown '\"@brief: Change file owner and/or group. .TP \fBchown \fR[\fB\-fileid\fR] \fIowner\fR | {\fIowner group\fR} \fIfilelist\fR .br Set owner of each file in the list \fIfilelist\fR to \fIowner\fR, which can be a user name or numeric user id. If the first parameter is a list, then the owner is set to the first element of the list and the group is set to the second element. \fIGroup\fR can be a group name or numeric group id. If \fIgroup\fR is {}, then the file group will be set to the login group of the specified user. .sp If the option \fB\-fileid\fR is specified, \fIfilelist\fR is a list of open file identifiers rather than a list of file names. This option is not available on all Unix systems. Use the \fBinfox have_fchown\fR command to determine if this functionality is available. .sp The \fBchown\fR command is not available on \fBWindows\fR. '\"@: '\"@:This command is provided by Extended Tcl. '\"@endhelp ' '\"@help: tcl/files/chgrp '\"@brief: Change file group. .TP \fBchgrp \fR[\fB\-fileid\fR] \fIgroup\fR \fIfilelist\fR .br Set the group id of each file in the list \fIfilelist\fR to \fIgroup\fR, which can be either a group name or a numeric group id. .sp If the option \fB\-fileid\fR is specified, \fIfilelist\fR is a list of open file identifiers rather than a list of file names. This option is not available on all Unix systems. Use the \fBinfox have_fchown\fR command to determine if this functionality is available. .sp The \fBchgrp\fR command is not available on \fBWindows\fR. '\"@: '\"@:This command is provided by Extended Tcl. '\"@endhelp ' '\"@help: tcl/files/dup '\"@brief: Duplicate an open file .TP \fBdup\fR \fIfileId\fR ?\fItargetFileId\fR? .br Duplicate an open file. A new file id is opened that addresses the same file as \fIfileId\fR. .sp If \fItargetFileId\fR is specified, the the file is dup to this specified file id. Normally this is \fBstdin\fR, \fBstdout\fR, or \fBstderr\fR. The dup command will handle flushing output and closing this file. The new file will be buffered, if its needs to be unbuffered, use the \fBfcntl\fR command to set it unbuffered. .sp If \fIfileId\fR is a number rather than a Tcl file id, then the \fBdup\fR command will bind that file to a Tcl file id. This is useful for accessing files that are passed from the parent process. The argument ?\fItargetFileId\fR? is not valid with this operation. .sp On \fBWindows\fR, only \fBstdin\fR, \fBstdout\fR, or \fBstderr\fR or a non-socket file handle number maybe specified for \fItargetFileId\fR. The \fBdup\fR command does not work on sockets on \fBWindows\fR. '\"@: '\"@:This command is provided by Extended Tcl. '\"@endhelp ' '\"@help: tcl/files/fcntl '\"@brief: Get or set file access options for an open file. .TP \fBfcntl\fR \fIfileId\fR \fIattribute ?value\fR? .br This command either sets or clears a file option or returns its current value. If \fIvalue\fR is not specified, then the current value of \fBattribute\fR is returned. All values are boolean. Some attributes maybe only be gotten, not modified. The following attributes may be specified: .IP \fBRDONLY\fR The file is opened for reading only. (Get only) .IP \fBWRONLY\fR The file is opened for writing only. (Get only) .IP \fBRDWR\fR The file is opened for reading and writing. (Get only) .IP "\fBREAD\fR " If the file is readable. (Get only). .IP \fBWRITE\fR If the file is writable. (Get only). .IP \fBAPPEND\fR The file is opened for append-only writes. All writes will be forced to the end of the file. (Get or set). .IP \fBNONBLOCK\fR The file is to be accessed with non-blocking I/O. See the \fBread\fR system call for a description of how it affects the behavior of file reads. .IP \fBCLOEXEC\fR Close the file on an process exec. If the \fBexecl\fR command or some other mechanism causes the process to do an exec, the file will be closed if this option is set. .IP \fBNOBUF\fR The file is not buffered. If set, then there no buffering for the file. .IP \fBLINEBUF\fR Output the file will be line buffered. The buffer will be flushed when a newline is written, when the buffer is full, or when input is requested. .IP \fBKEEPALIVE\fR Keep a socket connection alive. If SIGPIPE is enabled, then it is sent if connection is broken and data is written to the socket. If SIGPIPE is ignored, an error is returned on the write. This attribute is valid only on sockets. By default, SIGPIPE is ignored in Tcl. .IP The \fBNONBLOCK\fR, \fBNOBUF\fR and \fBLINEBUF\fR are provided for compatibility with older scripts. The\fBfconfigure\fR command is preferred method of getting and setting these attributes. .IP The \fBAPPEND\fR and \fBCLOEXEC\fR options are not available on \fBWindows\fR. .RE '\"@: '\"@:This command is provided by Extended Tcl. '\"@endhelp ' '\"@help: tcl/files/flock '\"@brief: Lock all or part of a file. .TP \fBflock\fR \fIoptions fileId\fR ?\fIstart\fR? ?\fIlength\fR? ?\fIorigin\fR? .IP This command places a lock on all or part of the file specified by \fIfileId\fR. The lock is either advisory or mandatory, depending on the mode bits of the file. The lock is placed beginning at relative byte offset \fIstart\fR for \fIlength\fR bytes. If \fIstart\fR or \fIlength\fR is omitted or empty, zero is assumed. If \fIlength\fR is zero, then the lock always extents to end of file, even if the file grows. If \fIorigin\fR is "\fBstart\fR", then the offset is relative to the beginning of the file. If it is "\fBcurrent\fR", it is relative to the current access position in the file. If it is "\fBend\fR", then it is relative to the end-of-file (a negative is before the EOF, positive is after). If \fIorigin\fR is omitted, \fBstart\fR is assumed. .IP The following \fIoptions\fR are recognized: .RS .IP \fB\-read\fR Place a read lock on the file. Multiple processes may be accessing the file with read-locks. .IP \fB\-write\fR Place a write lock on the file. Only one process may be accessing a file if there is a write lock. .IP \fB\-nowait\fR If specified, then the process will not block if the lock can not be obtained. With this option, the command returns 1 if the lock is obtained and 0 if it is not. .RE .IP See your system's \fBfcntl\fR system call documentation for full details of the behavior of file locking. If locking is being done on ranges of a file, it is best to use unbuffered file access (see the \fBfcntl\fR command). .IP The \fBflock\fR command is not available on \fBWindows 95\fR. It is available on \fBWindows NT\fR. '\"@: '\"@:This command is provided by Extended Tcl. '\"@endhelp ' '\"@help: tcl/files/for_file '\"@brief: Do a foreach-style loop on each line in a file. .TP \fBfor_file\fR \fIvar filename code\fR .br This procedure implements a loop over the contents of a file. For each line in \fIfilename\fR, it sets \fIvar\fR to the line and executes \fIcode\fR. .sp The \fBbreak\fR and \fBcontinue\fR commands work as with foreach. .sp For example, the command .sp .nf .ft CW for_file line /etc/passwd {echo $line} .ft R .fi .sp would echo all the lines in the password file. '\"@: '\"@:This procedure is provided by Extended Tcl. '\"@endhelp ' '\"@help: tcl/files/funlock '\"@brief: Remove a lock from part or all of a file. .TP \fBfunlock\fR \fIfileId\fR ?\fIstart\fR? ?\fIlength\fR? ?\fIorigin\fR? .br Remove a locked from a file that was previously placed with the \fIflock\fR command. The arguments are the same as for the \fIflock\fR command, see that command for more details. .sp The \fBfunlock\fR command is not available on \fBWindows 95\fR. It is available on \fBWindows NT\fR. '\"@: '\"@:This command is provided by Extended Tcl. '\"@endhelp ' '\"@help: tcl/files/fstat '\"@brief: Obtain status information about an open file. .TP \fBfstat\fR \fIfileId\fR ?\fIitem\fR? | ?\fBstat \fIarrayvar\fR? .IP Obtain status information about an open file. .IP The following keys are used to identify data items: .RS .IP "\fBatime\fR" The time of last access. .IP "\fBctime\fR" The time of last file status change .IP "\fBdev\fR" The device containing a directory for the file. This value uniquely identifies the file system that contains the file. .IP "\fBgid\fR" The group ID of the file's group. .IP "\fBino\fR" The inode number. This field uniquely identifies the file in a given file system. .IP "\fBmode\fR" The mode of the file (see the \fBmknod\fR system call). .IP "\fBmtime\fR" Time when the data in the file was last modified. .IP "\fBnlink\fR" The number of links to the file. .IP "\fBsize\fR" The file size in bytes. .IP "\fBtty\fR" If the file is associated with a terminal, then 1 otherwise 0. .IP "\fBtype\fR" The type of the file in symbolic form, which is one of the following values: \fBfile\fR, \fBdirectory\fR, \fBcharacterSpecial\fR, \fBblockSpecial\fR, \fBfifo\fR, \fBlink\fR, or \fBsocket\fR. .IP "\fBuid\fR" The user ID of the file's owner. .RE .IP If one of these keys is specified as \fIitem\fR, then that data item is returned. .IP If \fBstat \fIarrayvar\fR is specified, then the information is returned in the array \fIarrayvar\fR. Each of the above keys indexes an element of the array containing the data. .IP If only \fIfileId\fR is specified, the command returns the data as a keyed list. .IP The following values may be returned only if explicitly asked for, it will not be returned with the array or keyed list forms: .RS .IP "\fBremotehost\fR" If \fIfileId\fR is a TCP/IP socket connection, then a list is returned with the first element being the remote host IP address. If the remote host name can be found, it is returned as the second element of the list. The remote host IP port number is the third element. .IP "\fBlocalhost\fR" If \fIfileId\fR is a TCP/IP socket connection, then a list is returned with the first element being the local host IP address. If the local host name can be found, it is returned as the second element of the list. The local host IP port number is the third element. .RE '\"@: '\"@:This command is provided by Extended Tcl. '\"@endhelp ' '\"@help: tcl/files/ftruncate '\"@brief: Truncate a file to a specified size. .TP \fBftruncate \fR[\fB\-fileid\fR] \fIfile newsize\fR .br Truncate a file to have a length of at most \fInewsize\fR bytes. .sp If the option \fB\-fileid\fR is specified, \fIfile\fR is an open file identifier, otherwise it is a file path. .sp This command is not available or not fully functional if the underlying operating system support is not available. The command \fBinfox have_truncate\fR will indicate if this command may truncate by file path. The command \fBinfox have_ftruncate\fR will indicate if this command may truncate by file id. .sp The \fB\-fileid\fR option is not available on \fBWindows\fR. '\"@: '\"@:This command is provided by Extended Tcl. '\"@endhelp ' '\"@help: tcl/files/lgets '\"@brief: Read a list for a file, handles embedded newlines. .TP \fBlgets\fR \fIfileId\fR ?\fIvarName\fR? .br Reads the next Tcl list from the file given by \fIfileId\fR and discards the terminating newline character. This command differs from the \fBgets\fR command, in that it reads Tcl lists rather than lines. If the list contains newlines or binary data, then that newline or bytes of zero will be returned as part of the result. Only a newline not quoted as part of the list indicates the end of the list. There is no corresponding command for outputting lists, as \fBputs\fR will do this correctly. .sp If \fIvarName\fR is specified, then the line is placed in the variable by that name and the return value is a count of the number of characters read (not including the newline). If the end of the file is reached before reading any characters then \-1 is returned and \fIvarName\fR is set to an empty string. If \fIvarName\fR is specified and an error occurs, what ever data was read will be returned in the variable, however the resulting string may not be a valid list. .sp If \fIvarName\fR is not specified then the return value will be the line (minus the newline character) or an empty string if the end of the file is reached before reading any characters. An empty string will also be returned if a line contains no characters except the newline, so \fBeof\fR may have to be used to determine what really happened. .sp The \fBlgets\fR command maybe used to read and write lists containing binary data, however translation must be set to \fBlf\fR or the data maybe corrupted. .sp If \fBlgets\fR is currently supported on non-blocking files. '\"@: '\"@:This command is provided by Extended Tcl. '\"@endhelp ' ' '\"@help: tcl/files/pipe '\"@brief: Create a pipe. .TP \fBpipe\fR ?\fIfileId_var_r fileId_var_w\fR? .br Create a pipe. If \fIfileId_var_r\fR and \fIfileId_var_r\fR are specified, then \fBpipe\fR will set the a variable named \fIfileId_var_r\fR to contain the fileId of the side of the pipe that was opened for reading, and \fIfileId_var_w\fR will contain the fileId of the side of the pipe that was opened for writing. .sp If the fileId variables are not specified, then a list containing the read and write fileIdw is returned as the result of the command. '\"@: '\"@:This command is provided by Extended Tcl. '\"@endhelp ' '\"@help: tcl/files/read_file '\"@brief: Read in a file to a string. .TP \fBread_file\fR ?\fB\-nonewline\fR? \fIfileName\fR .TP \fBread_file\fR \fIfileName\fR \fInumBytes\fR .br This procedure reads the file \fIfileName\fR and returns the contents as a string. If \fB\-nonewline\fR is specified, then the last character of the file is discarded if it is a newline. The second form specifies exactly how many bytes will be read and returned, unless there are fewer than \fInumBytes\fR bytes left in the file; in this case, all the remaining bytes are returned. '\"@: '\"@:This procedure is provided by Extended Tcl. '\"@endhelp ' '\"@help: tcl/files/select '\"@brief: Synchronous I/O multiplexing. .TP \fBselect\fR \fIreadfileIds\fR ?\fIwritefileIds\fR? ?\fIexceptfileIds\fR? ?\fItimeout\fR? .br This command allows an Extended Tcl program to wait on zero or more files being ready for for reading, writing, have an exceptional condition pending, or for a timeout period to expire. \fIreadFileIds\fR, \fIwriteFileIds\fR, \fIexceptFileIds\fR are each lists of fileIds, as returned from \fBopen\fR, to query. An empty list ({}) may be specified if a category is not used. .sp The files specified by the \fIreadFileIds\fR list are checked to see if data is available for reading. The \fIwriteFileIds\fR are checked if the specified files are clear for writing. The \fIexceptFileIds\fR are checked to see if an exceptional condition has occurred (typically, an error). The write and exception checking is most useful on devices, however, the read checking is very useful when communicating with multiple processes through pipes. Select considers data pending in the stdio input buffer for read files as being ready for reading, the files do. not have to be unbuffered. .sp \fITimeout\fR is a floating point timeout value, in seconds. If an empty list is supplied (or the parameter is omitted), then no timeout is set. If the value is zero, then the \fBselect\fR command functions as a poll of the files, returning immediately even if none are ready. .sp If the \fItimeout\fR period expires with none of the files becoming ready, then the command returns an empty list. Otherwise the command returns a list of three elements, each of those elements is a list of the fileIds that are ready in the read, write and exception classes. If none are ready in a class, then that element will be the null list. For example: .sp .nf .ft CW select {file3 file4 file5} {file6 file7} {} 10.5 .ft R could return .ft CW {file3 file4} {file6} {} .ft R or perhaps .ft CW file3 {} {} .ft R .fi .sp On \fBWindows\fR, only sockets can be used with the \fBselect\fR command. Pipes, as returned by the \fBopen\fR command, are not supported. '\"@: '\"@:This command is provided by Extended Tcl. '\"@endhelp ' '\"@help: tcl/files/write_file '\"@brief: Write strings out to a file. .TP \fBwrite_file\fR \fIfileName string ?string...?\fR .br This procedure writes the specified strings to the named file. '\"@: '\"@:This procedure is provided by Extended Tcl. '\"@endhelp ' .bp .SH "NETWORK PROGRAMMING SUPPORT" .PP TclX provides functionality to complement the Tcl \fBsocket\fR command. The \fBhost_info\fR command is used to get information about a host by name or IP address. In addition, the \fBfstat\fR and \fBfcntl\fR commands provide options of querying and controlling connected sockets. To obtain the host name of the system the local system, use the \fBid host\fR command. ' '\"@help: tcl/sockets/host_info '\"@brief: Obtain information about an Internet host. .TP \fBhost_info \fIoption\fR \fIhost\fR .br Obtain information about an Internet host. The argument \fIhost\fR can be either a host name or an IP address. .IP The following subcommands are recognized: .RS .IP \fBaddresses\fR Return the list of IP addresses for \fIhost\fR. .IP \fBofficial_name\fR Return official name for \fIhost\fR. .IP \fBaliases\fR Return the list of aliases for \fIhost\fR. (Note that these are IP number aliases, not DNS \fICNAME\fR aliases. See \fIifconfig(2)\fR.) .RE '\"@endhelp ' .bp .SH "FILE SCANNING COMMANDS" .PP These commands provide a facility to scan files, matching lines of the file against regular expressions and executing Tcl code on a match. With this facility you can use Tcl to do the sort of file processing that is traditionally done with \fIawk\fR. And since Tcl's approach is more declarative, some of the scripts that can be rather difficult to write in awk are simple to code in Tcl. .PP File scanning in Tcl centers around the concept of a \fIscan context\fR. A scan context contains one or more match statements, which associate regular expressions to scan for with Tcl code to be executed when the expressions are matched. ' '\"@help: tcl/filescan/scancontext '\"@brief: Manage file scan contexts. .TP \fBscancontext\fR ?\fIoption\fR? .br This command manages file scan contexts. A scan context is a collection of regular expressions and commands to execute when that regular expression matches a line of the file. A context may also have a single default match, to be applied against lines that do not match any of the regular expressions. Multiple scan contexts may be defined and they may be reused on multiple files. A scan context is identified by a context handle. The \fBscancontext\fR command takes the following forms: .TP \fBscancontext create\fR Create a new scan context. The \fBscanmatch\fR command is used to define patterns in the context. A contexthandle is returned, which the Tcl programmer uses to refer to the newly created scan context in calls to the Tcl file scanning commands. ' .TP \fBscancontext delete\fR \fIcontexthandle\fR .br Delete the scan context identified by \fIcontexthandle\fR, and free all of the match statements and compiled regular expressions associated with the specified context. .TP \fBscancontext copyfile\fR \fIcontexthandle\fR ?\fIfilehandle\fR? .br Set or return the file handle that unmatched lines are copied to. (See \fBscanfile\fR). If \fIfilehandle\fR is omitted, the copy file handle is returned. If no copy file is associated with the context, {} is returned. If a file handle is specified, it becomes the copy file for this context. If \fIfilehandle\fR is {}, then it removes any copy file specification for the context. '\"@: '\"@:This command is provided by Extended Tcl. '\"@endhelp ' '\"@help: tcl/filescan/scanfile '\"@brief: Scan a file, executing match code when their patterns are matched. .TP \fBscanfile\fR ?\fI\-copyfile copyFileId\fR? \fIcontexthandle\fR \fIfileId\fR .br Scan the file specified by \fIfileId\fR, starting from the current file position. Check all patterns in the scan context specified by \fIcontexthandle\fR against it, executing the match commands corresponding to patterns matched. .sp If the optional \fI\-copyfile\fR argument is specified, the next argument is a file ID to which all lines not matched by any pattern (excluding the default pattern) are to be written. If the copy file is specified with this flag, instead of using the \fBscancontext copyfile\fR command, the file is disassociated from the scan context at the end of the scan. .sp This command does not work on files containing binary data (bytes of zero). '\"@: '\"@:This command is provided by Extended Tcl. '\"@endhelp '\"@help: tcl/filescan/scanmatch '\"@brief: Specify tcl code to execute when scanfile pattern is matched. .TP \fBscanmatch\fR ?\fI\-nocase\fR? \fIcontexthandle\fR ?\fIregexp\fR? \fIcommands\fR .IP Specify Tcl \fIcommands\fR, to be evaluated when \fIregexp\fR is matched by a \fBscanfile\fR command. The match is added to the scan context specified by \fIcontexthandle\fR. Any number of match statements may be specified for a give context. \fIRegexp\fR is a regular expression (see the \fBregexp\fR command). If \fB\-nocase\fR is specified as the first argument, the pattern is matched regardless of alphabetic case. .IP If \fIregexp\fR is not specified, then a default match is specified for the scan context. The default match will be executed when a line of the file does not match any of the regular expressions in the current scancontext. .IP The array \fBmatchInfo\fR is available to the Tcl code that is executed when an expression matches (or defaults). It contains information about the file being scanned and where within it the expression was matched. .IP \fBmatchInfo\fR is local to the top level of the match command unless declared global at that level by the Tcl \fBglobal\fR command. If it is to be used as a global, it \fImust\fR be declared global before \fBscanfile\fR is called (since \fBscanfile\fR sets the \fBmatchInfo\fR before the match code is executed, a subsequent \fBglobal\fR will override the local variable). The following array entries are available: .RS .TP \fBmatchInfo(line)\fR Contains the text of the line of the file that was matched. .TP \fBmatchInfo(offset)\fR The byte offset into the file of the first character of the line that was matched. .\".TP .\"\fBmatchInfo(bytesread)\fR .\"The number of translated bytes that have been read since the start of the .\"scan, including the number of bytes in the current line. .\"If end-of-line translation is enabled or automatic, the terminating characters .\"only count as one byte, even if \fBcrlf\fR two character terminators are used. .\"This has the advantage of giving a value that can be passed to the \fBread\fR .\"command to get a specific block of data. .TP \fBmatchInfo(linenum)\fR The line number of the line that was matched. This is relative to the first line scanned, which is usually, but not necessarily, the first line of the file. The first line is line number one. .TP \fBmatchInfo(context)\fR The context handle of the context that this scan is associated with. .TP \fBmatchInfo(handle)\fR The file id (handle) of the file currently being scanned. .TP \fBmatchInfo(copyHandle)\fR The file id (handle) of the file specified by the \fB\-copyfile\fR option. The element does not exist if \fB\-copyfile\fR was not specified. .TP \fBmatchInfo(submatch0)\fR Will contain the characters matching the first parenthesized subexpression. The second will be contained in \fBsubmatch1\fR, etc. .TP \fBmatchInfo(subindex0)\fR Will contain the a list of the starting and ending indices of the string matching the first parenthesized subexpression. The second will be contained in \fBsubindex1\fR, etc. .RE .IP All \fBscanmatch\fR patterns that match a line will be processed in the order in which their specifications were added to the scan context. The remainder of the \fBscanmatch\fR pattern-command pairs may be skipped for a file line if a \fBcontinue\fR is executed by the Tcl code of a preceding, matched pattern. .IP If a \fBreturn\fR is executed in the body of the match command, the \fBscanfile\fR command currently in progress returns, with the value passed to \fBreturn\fR as its return value. '\"@: '\"@:This command is provided by Extended Tcl. '\"@endhelp ' .bp .SH "MATH COMMANDS" .PP Several extended math commands commands make many additional math functions available in TclX. In addition, a set of procedures provide command access to the math functions supported by the \fBexpr\fR command. '\"@help: tcl/math/fmathcmds '\"@brief: Command interfaces to the expr math functions (sin, cos, tan, etc). .PP The following procedures provide command interfaces to the expr math functions. They take the same arguments as the \fBexpr\fR functions and may take expressions as arguments. .sp .RS .nf .ta 3c 6c 9c \fBabs\fR \fBacos\fR \fBasin\fR \fBatan2\fR \fBatan\fR \fBceil\fR \fBcos\fR \fBcosh\fR \fBdouble\fR \fBexp\fR \fBfloor\fR \fBfmod\fR \fBhypot\fR \fBint\fR \fBlog10\fR \fBlog\fR \fBpow\fR \fBround\fR \fBsin\fR \fBsinh\fR \fBsqrt\fR \fBtan\fR \fBtanh\fR .fi .RE '\"@: '\"@:These procedures are provided by Extended Tcl. '\"@endhelp ' '\"@help: tcl/math/max '\"@brief: Return the argument that has the highest numeric value. .TP \fBmax\fR \fInum1\fR ?..\fInumN\fR? .TP \fBexpr max(num1, num2)\fR .br Returns the argument that has the highest numeric value. Each argument may be any integer or floating point value. .sp This functionality is also available as a math function \fBmax\fR in the Tcl \fBexpr\fR command. '\"@: '\"@:This command is provided by Extended Tcl. '\"@endhelp ' '\"@help: tcl/math/min '\"@brief: Return the argument that has the lowest numeric value. .TP \fBmin\fR \fInum1\fR ?..\fInumN\fR? .TP \fBexpr min(num1, num2)\fR .br Returns the argument that has the lowest numeric value. Each argument may be any integer or floating point value. .sp This functionality is also available as a math function \fBmin\fR in the Tcl \fBexpr\fR command. '\"@: '\"@:This command is provided by Extended Tcl. '\"@endhelp ' '\"@help: tcl/math/random '\"@brief: Return a pseudorandom integer or set the seed. .TP \fBrandom\fR \fIlimit\fR | \fBseed\fR ?\fIseedval\fR? .br Generate a pseudorandom integer number greater than or equal to zero and less than \fIlimit\fR. If \fBseed\fR is specified, then the command resets the random number generator to a starting point derived from the \fBseedval\fR. This allows one to reproduce pseudorandom number sequences for testing purposes. If \fIseedval\fR is omitted, then the seed is set to a value based on current system state and the current time, providing a reasonably interesting and ever-changing seed. '\"@: '\"@:This command is provided by Extended Tcl. '\"@endhelp ' .bp .SH "LIST MANIPULATION COMMANDS" .PP Extended Tcl provides additional list manipulation commands and procedures. ' '\"@help: tcl/lists/intersect '\"@brief: Return a list containing every element present in both lists. .TP \fBintersect\fR \fIlista listb\fR .br Procedure to return the logical intersection of two lists. The returned list will be sorted. '\"@: '\"@:This procedure is provided by Extended Tcl. '\"@endhelp ' '\"@help: tcl/lists/intersect3 '\"@brief: Return three lists from an intersection of two lists. .TP \fBintersect3\fR \fIlista listb\fR .br Procedure to intersects two lists, returning a list containing three lists: The first list returned is everything in \fIlista\fR that wasn't in \fIlistb\fR. The second list contains the intersection of the two lists, and the third list contains all the elements that were in \fIlistb\fR but weren't in \fIlista\fR. The returned lists will be sorted. '\"@: '\"@:This procedure is provided by Extended Tcl. '\"@endhelp ' '\"@help: tcl/lists/lassign '\"@brief: Assign successive elements of a list to specified variables. .TP \fBlassign\fR \fIlist var\fR ?\fIvar\fR...? .br Assign successive elements of a list to specified variables. If there are more variable names than fields, the remaining variables are set to the empty string. If there are more elements than variables, a list of the unassigned elements is returned. .sp For example, .sp .nf .ft CW lassign {dave 100 200 {Dave Foo}} name uid gid longName .ft R .fi .sp Assigns \fIname\fR to ``dave'', \fIuid\fR to ``100'', \fIgid\fR to ``200'', and \fIlongName\fR to ``Dave Foo''. '\"@: '\"@:This command is provided by Extended Tcl. '\"@endhelp ' '\"@help: tcl/lists/lcontain '\"@brief: Determine if a list contains an element. .TP \fBlcontain\fR \fIlist element\fR .br Determine if the \fIelement\fR is a list element of \fIlist\fR. If the element is contained in the list, 1 is returned, otherwise, 0 is returned. '\"@: '\"@:This command is provided by Extended Tcl. '\"@endhelp ' '\"@help: tcl/lists/lempty '\"@brief: Determine if a list is empty. .TP \fBlempty\fR \fIlist\fR .br Determine if the specified list is empty. If empty, 1 is returned, otherwise, 0 is returned. This command is an alternative to comparing a list to an empty string, however it checks for a string of all whitespaces, which is an empty list. '\"@: '\"@:This command is provided by Extended Tcl. '\"@endhelp ' '\"@help: tcl/lists/lmatch '\"@brief: Return a list of elements from a list that match a pattern .TP \fBlmatch \fR?\fImode\fR? \fIlist pattern\fR .IP Search the elements of \fIlist\fR, returning a list of all elements matching \fIpattern\fR. If none match, an empty list is returned. .IP The \fImode\fR argument indicates how the elements of the list are to be matched against \fIpattern\fR and it must have one of the following values: .RS .IP \fB\-exact\fR The list element must contain exactly the same string as \fIpattern\fR. .IP \fB\-glob\fR \fIPattern\fR is a glob-style pattern which is matched against each list element using the same rules as the \fBstring match\fR command. .IP \fB\-regexp\fR \fIPattern\fR is treated as a regular expression and matched against each list element using the same rules as the \fBregexp\fR command. .RE .IP If \fImode\fR is omitted then it defaults to \fB\-glob\fR. .sp Only the \fB-exact\fR comparison will work on binary data. '\"@: '\"@:This command is provided by Extended Tcl. '\"@endhelp ' '\"@help: tcl/lists/lrmdups '\"@brief: Given a list, remove all of the duplicated elements. .TP \fBlrmdups\fR \fIlist\fR .br Procedure to remove duplicate elements from a list. The returned list will be sorted. '\"@: '\"@:This procedure is provided by Extended Tcl. '\"@endhelp ' '\"@help: tcl/lists/lvarcat '\"@brief: Concatenate the contents lists or strings into a variable .TP \fBlvarcat\fI var string ?\fR\fIstring...\fR? .br This command treats each \fIstring\fR argument as a list and concatenates them to the end of the contents of \fIvar\fR, forming a a single list. The list is stored back into \fIvar\fR and also returned as the result. if \fIvar\fR does not exist, it is created. '\"@: '\"@:This command is provided by Extended Tcl. '\"@endhelp ' '\"@help: tcl/lists/lvarpop '\"@brief: Pop or replace the specified element from a list. .TP \fBlvarpop\fR \fIvar\fR ?\fIindexExpr\fR? ?\fIstring\fR? .br The \fBlvarpop\fR command pops (deletes) the element indexed by the expression \fIindexExpr\fR from the list contained in the variable \fIvar\fR. If \fIindex\fR is omitted, then 0 is assumed. If \fIstring\fR, is specified, then the deleted element is replaced by \fIstring\fR. The replaced or deleted element is returned. Thus ``lvarpop argv 0'' returns the first element of argv, setting argv to contain the remainder of the string. .sp If the expression \fIindexExpr\fR starts with the string \fBend\fR, then \fBend\fR is replaced with the index of the last element in the list. If the expression starts with \fBlen\fR, then \fBlen\fR is replaced with the length of the list. '\"@: '\"@:This command is provided by Extended Tcl. '\"@endhelp ' '\"@help: tcl/lists/lvarpush '\"@brief: Push or insert the an element into a list. .TP \fBlvarpush\fR \fIvar string\fR ?\fIindexExpr\fR? .br The \fBlvarpush\fR command pushes (inserts) \fIstring\fR as an element in the list contained in the variable \fIvar\fR. The element is inserted before position \fIindexExpr\fR in the list. If \fIindex\fR is omitted, then 0 is assumed. If \fIvar\fR does not exists, it is created. .sp If the expression \fIindexExpr\fR starts with the string \fBend\fR, then \fBend\fR is replaced with the index of the last element in the list. If the expression starts with \fBlen\fR, then \fBlen\fR is replaced with the length of the list. Note the a value of \fBend\fR means insert the string before the last element. '\"@: '\"@:This command is provided by Extended Tcl. '\"@endhelp ' '\"@help: tcl/lists/union '\"@brief: Return the logical union of two lists. .TP \fBunion\fR \fIlista listb\fR Procedure to return the logical union of the two specified lists. Any duplicate elements are removed. '\"@: '\"@:This procedure is provided by Extended Tcl. '\"@endhelp ' '\"@help: tcl/intro/keyedlists '\"@brief: Introduction to keyed lists .bp .SH "KEYED LISTS" .PP Extended Tcl defines a special type of list referred to as \fIkeyed lists\fR. These lists provided a structured data type built upon standard Tcl lists. This provides a functionality similar to \fIstruct\fRs in the C programming language. .sp A keyed list is a list in which each element contains a key and value pair. These element pairs are stored as lists themselves, where the key is the first element of the list, and the value is the second. The key-value pairs are referred to as \fIfields\fR. This is an example of a keyed list: .IP {{NAME {Frank Zappa}} {JOB {musician and composer}}} ' .PP If the variable \fBperson\fR contained the above list, then \fBkeylget person NAME\fR would return \fB{Frank Zappa}\fR. Executing the command: .sp .nf .ft CW keylset person ID 106 .ft R .fi .PP would make \fBperson\fR contain .IP {{ID 106} {NAME {Frank Zappa}} {JOB {musician and composer}} .PP Fields may contain subfields; `.' is the separator character. Subfields are actually fields where the value is another keyed list. Thus the following list has the top level fields \fIID\fR and \fINAME\fR, and subfields \fINAME.FIRST\fR and \fINAME.LAST\fR: .IP {ID 106} {NAME {{FIRST Frank} {LAST Zappa}}} .PP There is no limit to the recursive depth of subfields, allowing one to build complex data structures. .PP Keyed lists are constructed and accessed via a number of commands. All keyed list management commands take the name of the variable containing the keyed list as an argument (i.e. passed by reference), rather than passing the list directly. '\"@: '\"@:This functionality is provided by Extended Tcl. '\"@endhelp ' '\"@help: tcl/keyedlists/keyldel '\"@brief: Delete a field of a keyed list. .TP \fBkeyldel\fR \fIlistvar\fR \fIkey\fR .br Delete the field specified by \fIkey\fR from the keyed list in the variable \fIlistvar\fR. This removes both the key and the value from the keyed list. '\"@: '\"@:This command is provided by Extended Tcl. '\"@endhelp ' '\"@help: tcl/keyedlists/keylget '\"@brief: Get the value of a field of a keyed list. .TP \fBkeylget\fR \fIlistvar\fR ?\fIkey\fR? ?\fIretvar\fR | {}? .br Return the value associated with \fIkey\fR from the keyed list in the variable \fIlistvar\fR. If \fIretvar\fR is not specified, then the value will be returned as the result of the command. In this case, if \fIkey\fR is not found in the list, an error will result. .sp If \fIretvar\fR is specified and \fIkey\fR is in the list, then the value is returned in the variable \fIretvar\fR and the command returns \fB1\fR if the key was present within the list. If \fIkey\fR isn't in the list, the command will return \fB0\fR, and \fIretvar\fR will be left unchanged. If \fB{}\fR is specified for \fIretvar\fR, the value is not returned, allowing the Tcl programmer to determine if a key is present in a keyed list without setting a variable as a side-effect. .sp If \fIkey\fR is omitted, then a list of all the keys in the keyed list is returned. '\"@: '\"@:This command is provided by Extended Tcl. '\"@endhelp ' '\"@help: tcl/keyedlists/keylkeys '\"@brief: Get the keys in a keyed list. .TP \fBkeylkeys\fR \fIlistvar\fR ?\fIkey\fR? .br Return the a list of the keys in the keyed list in the variable \fIlistvar\fR. If \fIkeys\fR is specified, then it is the name of a key field who's subfield keys are to be retrieve. '\"@: '\"@:This command is provided by Extended Tcl. '\"@endhelp ' '\"@help: tcl/keyedlists/keylset '\"@brief: Set the value of a field of a keyed list. .TP \fBkeylset\fR \fIlistvar\fR \fIkey\fR \fIvalue\fR ?\fIkey2\fR \fIvalue2\fR ...? .br Set the value associated with \fIkey\fR, in the keyed list contained in the variable \fIlistvar\fR, to \fIvalue\fR. If \fRlistvar\fR does not exists, it is created. If \fIkey\fR is not currently in the list, it will be added. If it already exists, \fIvalue\fR replaces the existing value. Multiple keywords and values may be specified, if desired. '\"@: '\"@:This command is provided by Extended Tcl. '\"@endhelp ' .bp .SH "STRING AND CHARACTER MANIPULATION COMMANDS" .PP The commands provide additional functionality to classify characters, convert characters between character and numeric values, index into a string, determine the length of a string, extract a range of character from a string, replicate a string a number of times, and transliterate a string (similar to the Unix \fItr\fR program). ' '\"@help: tcl/strings/ccollate '\"@brief: String comparison command (include localized collation). .TP \fBccollate\fR ?\fI\-local\fR? \fIstring1 string2\fR .br This command compares two strings. If returns \fB\-1\fR if \fIstring1\fR is less than \fIstring2\fR, \fB0\fR if they are equal and \fB1\fR if \fIstring1\fR is greater than \fIstring2\fR. .sp If \fB\-local\fR is specified, the strings are compared according to the collation environment of the current locale. .sp This command does not work with binary or UTF data. '\"@: '\"@:This command is provided by Extended Tcl. '\"@endhelp ' '\"@help: tcl/strings/cconcat '\"@brief: Concatenate strings. .TP \fBcconcat\fR ?\fIstring1\fR? ?\fIstring2\fR? ?...?\fR .br Concatenate the arguments, returning the resulting string. While string concatenation is normally performed by the parser, it is occasionally useful to have a command that returns a string. The is generally useful when a command to evaluate is required. No separators are inserted between the strings. .sp This command is UTF-aware. '\"@: '\"@:This command is provided by Extended Tcl. '\"@endhelp ' '\"@help: tcl/strings/cequal '\"@brief: String equality convenience command. .TP \fBcequal\fR \fIstring string\fR .br This command compares two strings for equality. It returns \fB1\fR if \fIstring1\fR and \fIstring2\fR are the identical and \fB0\fR if they are not. This command is a short-cut for \fBstring compare\fR and avoids the problems with string expressions being treated unintentionally as numbers. .sp This command is UTF-aware and will also work on binary data. '\"@: '\"@:This command is provided by Extended Tcl. '\"@endhelp ' '\"@help: tcl/strings/cindex '\"@brief: Return indexed character from string. .TP \fBcindex\fR \fIstring indexExpr\fR .br Returns the character indexed by the expression \fIindexExpr\fR (zero based) from \fIstring\fR. .sp If the expression \fIindexExpr\fR starts with the string \fBend\fR, then \fBend\fR is replaced with the index of the last character in the string. If the expression starts with \fBlen\fR, then \fBlen\fR is replaced with the length of the string. .sp This command is UTF-aware. '\"@: '\"@:This command is provided by Extended Tcl. '\"@endhelp '\"@help: tcl/strings/clength '\"@brief: Return length of specified string. .TP \fBclength\fR \fIstring\fR .br Returns the length of \fIstring\fR in characters. This command is a shortcut for: .br .nf .ft CW string length string .ft R .fi .sp This command is UTF-aware. '\"@: '\"@:This command is provided by Extended Tcl. '\"@endhelp ' '\"@help: tcl/strings/crange '\"@brief: Return range of characters from string. .TP \fBcrange\fR \fIstring firstExpr lastExpr\fR .br Returns a range of characters from \fIstring\fR starting at the character indexed by the expression \fIfirstExpr\fR (zero-based) until the character indexed by the expression \fIlastExpr\fR. .sp If the expression \fIfirstExpr\fR or \fBlastExpr\fR starts with the string \fBend\fR, then \fBend\fR is replaced with the index of the last character in the string. If the expression starts with \fBlen\fR, then \fBlen\fR is replaced with the length of the string. .sp This command is UTF-aware. '\"@: '\"@:This command is provided by Extended Tcl. '\"@endhelp ' '\"@help: tcl/strings/csubstr '\"@brief: Return a substring from within a string. .TP \fBcsubstr\fR \fIstring firstExpr lengthExpr\fR .br Returns a range of characters from \fIstring\fR starting at the character indexed by the expression \fIfirstExpr\fR (zero-based) for \fIlengthExpr\fR characters. .sp If the expression \fIfirstExpr\fR or \fBlengthExpr\fR starts with the string \fBend\fR, then \fBend\fR is replaced with the index of the last character in the string. If the expression starts with \fBlen\fR, then \fBlen\fR is replaced with the length of the string. .sp This command is UTF-aware. '\"@: '\"@:This command is provided by Extended Tcl. '\"@endhelp ' '\"@help: tcl/strings/ctoken '\"@brief: Parse a token from a character string. .TP \fBctoken\fR \fIstrvar separators\fR .br Parse a token out of a character string. The string to parse is contained in the variable named \fIstrvar\fR. The string \fIseparators\fR contains all of the valid separator characters for tokens in the string. All leading separators are skipped and the first token is returned. The variable \fIstrvar\fR will be modified to contain the remainder of the string following the token. .sp This command does not work with binary data. '\"@: '\"@:This command is provided by Extended Tcl. '\"@endhelp ' '\"@help: tcl/strings/ctype '\"@brief: Determine if a string has various characteristics. .TP \fBctype\fR \fI?\-failindex var? class string\fR .br \fBctype\fR determines whether all characters in \fIstring\fR are of the specified \fIclass\fR. It returns \fB1\fR if they are all of \fIclass\fR, and \fB0\fR if they are not, or if the string is empty. This command also provides another method (besides \fBformat\fR and \fBscan\fR) of converting between an ASCII character and its numeric value. The following \fBctype\fR commands are available: .RS .TP \fBctype\fR \fI?\-failindex var? alnum \fIstring\fR Tests that all characters are alphabetic or numeric characters as defined by the character set. .TP \fBctype\fR \fI?\-failindex var? alpha \fIstring\fR Tests that all characters are alphabetic characters as defined by the character set. .TP \fBctype\fR \fI?\-failindex var? ascii \fIstring\fR Tests that all characters are an ASCII character (a non-negative number less than 0200). .TP \fBctype char\fR \fInumber\fR Converts the numeric value, \fIstring\fR, to an ASCII character. Number must be in the range 0 through the maximum Unicode values. .TP \fBctype\fR \fI?\-failindex var? cntrl \fIstring\fR Tests that all characters are ``control characters'' as defined by the character set. .TP \fBctype\fR \fI?\-failindex var? digit \fIstring\fR Tests that all characters are valid decimal digits, i.e. 0 through 9. .TP \fBctype\fR \fI?\-failindex var? graph \fIstring\fR Tests that all characters within are any character for which \fIctype print\fR is true, except for space characters. .TP \fBctype\fR \fI?\-failindex var? lower \fIstring\fR Tests that all characters are lowercase letters as defined by the character set. .TP \fBctype ord\fR \fIcharacter\fR Convert a character into its decimal numeric value. The first character of the string is converted to its numeric Unicode value. .TP \fBctype\fR \fI?\-failindex var? space \fIstring\fR Tests that all characters are either a space, horizontal-tab, carriage return, newline, vertical-tab, or form-feed. .TP \fBctype\fR \fI?\-failindex var? print \fIstring\fR Tests that all characters are a space or any character for which \fIctype alnum\fR or \fIctype punct\fR is true or other ``printing character'' as defined by the character set. .TP \fBctype\fR \fI?\-failindex var? punct \fIstring\fR Tests that all characters are made up of any of the characters other than the ones for which \fBalnum\fR, \fBcntrl\fR, or \fBspace\fR is true. .TP \fBctype\fR \fI?\-failindex var? upper \fIstring\fR Tests that all characters are uppercase letters as defined by the character set. .TP \fBctype\fR \fI?\-failindex var? xdigit \fIstring\fR Tests that all characters are valid hexadecimal digits, that is \fI0\fR through \fI9\fR, a through \fIf\fR or \fIA\fR through \fIF\fR. .RE .IP If \fI\-failindex\fR is specified, then the index into \fIstring\fR of the first character that did not match the class is returned in \fIvar\fR. '\"@: '\"@:This command is provided by Extended Tcl. '\"@endhelp ' '\"@help: tcl/strings/replicate '\"@brief: Replicate string a number of times. .TP \fBreplicate\fR \fIstring countExpr\fR .br Returns \fIstring\fR, replicated the number of times indicated by the expression \fIcountExpr\fR. .sp This command is UTF-aware and will work with binary data. '\"@: '\"@:This command is provided by Extended Tcl. '\"@endhelp ' '\"@help: tcl/strings/translit '\"@brief: Translate characters in a string according to patterns. .TP \fBtranslit\fR \fIinrange outrange string\fR .br Translate characters in \fIstring\fR, changing characters occurring in \fIinrange\fR to the corresponding character in \fIoutrange\fR. \fIInrange\fR and \fIoutrange\fR may be list of characters or a range in the form `A\-M'. For example: .nf .ft CW translit a\-z A\-Z foobar .ft R .if returns "FOOBAR". .sp This command currently only supports characters in ASCII range; UTF-8 characters out of this range will generate an error. '\"@: '\"@:This command is provided by Extended Tcl. '\"@endhelp ' .bp .SH "XPG/3 MESSAGE CATALOG COMMANDS" .PP These commands provide a Tcl interface to message catalogs that are compliant with the X/Open Portability Guide, Version 3 (XPG/3). .sp Tcl programmers can use message catalogs to create applications that are language-independent. Through the use of message catalogs, prompts, messages, menus and so forth can exist for any number of languages, and they can altered, and new languages added, without affecting any Tcl or C source code, greatly easing the maintenance difficulties incurred by supporting multiple languages. .sp A default text message is passed to the command that fetches entries from message catalogs. This allows the Tcl programmer to create message catalogs containing messages in various languages, but still have a set of default messages available regardless of the presence of any message catalogs, and allow the programs to press on without difficulty when no catalogs are present. .sp Thus, the normal approach to using message catalogs is to ignore errors on \fBcatopen\fR, in which case \fBcatgets\fR will return the default message that was specified in the call. .sp The Tcl message catalog commands normally ignore most errors. If it is desirable to detect errors, a special option is provided. This is normally used only during debugging, to insure that message catalogs are being used. If your Unix implementation does not have XPG/3 message catalog support, stubs will be compiled in that will create a version of \fBcatgets\fR that always returns the default string. This allows for easy porting of software to environments that don't have support for message catalogs. .sp Message catalogs are global to the process, an application with multiple Tcl interpreters within the same process may pass and share message catalog handles. ' '\"@help: tcl/intl/catopen '\"@brief: Open a message catalog. .TP \fBcatopen\fR ?\fB\-fail\fR | \fB\-nofail\fR? \fIcatname\fR .br Open the message catalog \fIcatname\fR. This may be a relative path name, in which case the \fBNLSPATH\fR environment variable is searched to find an absolute path to the message catalog. A handle in the form \fBmsgcat\fIN\fR is returned. Normally, errors are ignored, and in the case of a failed call to \fBcatopen\fR, a handle is returned to an unopened message catalog. (This handle may still be passed to \fBcatgets\fR and \fBcatclose\fR, causing \fBcatgets\fR to simply return the default string, as described above. If the \fB\-fail\fR option is specified, an error is returned if the open fails. The option \fB\-nofail\fR specifies the default behavior of not returning an error when \fBcatopen\fR fails to open a specified message catalog. If the handle from a failed \fBcatopen\fR is passed to \fBcatgets\fR, the default string is returned. '\"@: '\"@:This command is provided by Extended Tcl. '\"@endhelp ' '\"@help: tcl/intl/catgets '\"@brief: Retrieve a message from a message catalog. .TP \fBcatgets\fR \fIcatHandle setnum msgnum defaultstr\fR .br Retrieve a message form a message catalog. \fICatHandle\fR should be a Tcl message catalog handle that was returned by \fBcatopen\fR. \fISetnum\fR is the message set number, and \fImsgnum\fR is the message number. If the message catalog was not opened, or the message set or message number cannot be found, then the default string, \fIdefaultstr\fR, is returned. '\"@: '\"@:This command is provided by Extended Tcl. '\"@endhelp ' '\"@help: tcl/intl/catclose '\"@brief: Close a message catalog. .TP \fBcatclose\fR ?\fB\-fail\fR | \fB\-nofail\fR? \fIcathandle\fR .br Close the message catalog specified by \fIcathandle\fR. Normally, errors are ignored. If \fB\-fail\fR is specified, any errors closing the message catalog file are returned. The option \fB\-nofail\fR specifies the default behavior of not returning an error. The use of \fB\-fail\fR only makes sense if it was also specified in the call to \fBcatopen\fR. '\"@: '\"@:This command is provided by Extended Tcl. '\"@endhelp ' .bp '\"@help: tcl/events/mainloop '\"@brief: Setup a top-level event loop. .TP \fBmainloop\fR .br This procedure sets up a top-level event loop. Events are processed until there are no more active event sources, at which time the process exits. It is used to build event oriented programs using the TclX shell in a style similar to that used with \fBwish\fR. If the global variable \fBtcl_interactive\fR exists and has a true value an interactive command handler is started as well. If the command handler is terminated by an EOF, the process will be exited. '\"@: '\"@:This procedure is provided by Extended Tcl. '\"@endhelp ' .bp .SH "HELP FACILITY" '\"@help: help '\"@brief: Tcl help facility. .PP The help facility allows one to look up help pages which where extracted from the standard Tcl manual pages and Tcl scripts during Tcl installation. Help files are structured as a multilevel tree of subjects and help pages. Help files are found by searching directories named \fBhelp\fR in the directories listed in the \fBauto_path\fR variable. All of the files in the list of help directories form a virtual root of the help tree. This method allows multiple applications to provide help trees without having the files reside in the same directory. .PP The help facility can be accessed in two ways, as interactive commands in the Extended Tcl shell or as an interactive Tk-based program (if you have built Extended Tcl with Tk). .PP To run the Tk-based interactive help program: .sp .nf .ft CW tclhelp ?addpaths? .ft R .fi .sp Where \fIaddpaths\fR are additional paths to search for help directories. By default, only the \fIauto_path\fR used by \fBtclhelp\fR is search. This will result in help on Tcl, Extended Tcl and Tk. .PP The following interactive Tcl commands and options are provided with the help package: .TP \fBhelp\fR .br Help, without arguments, lists of all the help subjects and pages under the current help subject. .TP \fBhelp\fR \fIsubject\fR Displays all of help pages and lower level subjects (if any exist) under the subject \fIsubject\fR. .TP \fBhelp\fR \fIsubject/helppage\fR Display the specified help page. The help output is passed through a simple pager if output exceeds 23 lines, pausing waiting for a return to be entered. If any other character is entered, the output is terminated. .TP \fBhelpcd\fR ?\fIsubject\fR? Change the current subject, which is much like the Unix current directory. If \fIsubject\fR is not specified, return to the top-level of the help tree. Help subject path names may also include ``..'' elements. .TP \fBhelppwd\fR Displays the current help subject. .TP \fBhelp\fR \fIhelp\fR | ? Displays help on the help facility at any directory level. .TP \fBapropos\fR \fIpattern\fR This command locates subjects by searching their one-line descriptions for a pattern. \fRApropos\fR is useful when you can remember part of the name or description of a command, and want to search through the one-line summaries for matching lines. Full regular expressions may be specified (see the \fBregexp\fR command). '\"@: '\"@:These procedures are provided by Extended Tcl. '\"@endhelp ' '\"@help: tcl/libraries/packagelib '\"@brief: Tcl loadable libraries and packages. .bp .SH "TCL LOADABLE LIBRARIES AND PACKAGES" .PP Extended Tcl supports standard Tcl \fBtclIndex\fR libraries and package libraries. A package library file can contain multiple independent Tcl packages. A package is a named collection of related Tcl procedures and initialization code. .PP The package library file is just a regular Unix text file, editable with your favorite text editor, containing packages of Tcl source code. The package library file name must have the suffix \fB.tlib\fR. An index file with the same prefix name and the suffix \fB.tndx\fR resides the same directory as the \fB.tlib\fR file. The \fB.tndx\fR will be automatically created whenever it is out of date or missing (provided there is write access to the directory). .PP The variable \fBauto_path\fR contains a list of directories that are searched for libraries. The first time an unknown command trap is take, the indexes for the libraries are loaded into memory. If the \fBauto_path\fR variable is changed during execution of a program, it will be re-searched. Only the first package of a given name found during the execution of a program is loaded. This can be overridden with \fBloadlibindex\fR command. .PP The start of a package is delimited by: .IP \fB#@package\fR: \fIpackage_name proc1\fR ?\fI..procN\fR? .PP These lines must start in column one. Everything between the \fB#@package:\fR keyword and the next \fB#@package:\fR keyword or a \fB#@packend\fR keyword, or the end of the file, becomes part of the named package. The specified procedures, \fIproc1..procN\fR, are the entry points of the package. When a command named in a package specification is executed and detected as an unknown command, all code in the specified package will be sourced. This package should define all of the procedures named on the package line, define any support procedures required by the package and do any package-specific initialization. Packages declarations maybe continued on subsequent lines using standard Tcl backslash line continuations. The \fB#@packend\fR keyword is useful to make sure only the minimum required section of code is sourced. Thus for example a large comment block at the beginning of the next file won't be loaded. .PP Care should be taken in defining \fIpackage_name\fR, as the first package found in the path by with a given name is loaded. This can be useful in developing new version of packages installed on the system. .PP For example, in a package source file, the presence of the following line: .IP \fB#@package: directory_stack pushd popd dirs\fR .PP says that the text lines following that line in the package file up to the next \fIpackage\fR line or the end of the file is a package named \fBdirectory_stack\fR and that an attempt to execute either \fIpushd\fR, \fIpopd\fR or \fIdirs\fR when the routine is not already defined will cause the \fBdirectory_stack\fR portion of the package file to be loaded. '\"@: '\"@:This functionality is provided by Extended Tcl. '\"@endhelp ' .bp .SH "PACKAGE LIBRARY MANAGEMENT COMMANDS" .PP Several commands are available for building and managing package libraries. Commands that are extended versions of the standard Tcl library commands are listed here. All of the standard Tcl library management commands and variables are also supported. ' .TP '\"@help: tcl/libraries/auto_commands '\"@brief: List names of loadable library commands and procedures. \fBauto_commands\fR ?\fB\-loaders\fR? Lists the names of all known loadable procedures and commands procedures. If \fB\-loaders\fR is specified, the command that will be executed to load the command will also be returned. '\"@: '\"@:This procedure is provided by Extended Tcl. '\"@endhelp ' .TP '\"@help: tcl/libraries/buildpackageindex '\"@brief: Build index files for package libraries. \fBbuildpackageindex\fR \fIlibfilelist\fR .br Build index files for package libraries. The argument \fIlibfilelist\fR is a list of package libraries. Each name must end with the suffix \fB.tlib\fR. A corresponding \fB.tndx\fR file will be built. The user must have write access to the directory containing each library. '\"@: '\"@:This procedure is provided by Extended Tcl. '\"@endhelp ' .TP '\"@help: tcl/libraries/convert_lib '\"@brief: Convert an Ousterhout style tclIndex file to a package library. \fBconvert_lib\fR \fItclIndex packagelib ?ignore?\fR .br Convert a Ousterhout style \fItclIndex\fR index file and associate source files into a package library \fBpackagelib\fR. If \fBpackagelib\fR does not have a \fB.tlib\fR extension, one will be added. Any files specified in \fItclIndex\fR that are in the list \fIignore\fR will be skipped. Files listed in \fIignore\fR should just be the base file names, not full paths. '\"@: '\"@:This procedure is provided by Extended Tcl. '\"@endhelp ' .TP '\"@help: tcl/libraries/loadlibindex '\"@brief: Load the index of a package library \fBloadlibindex\fR \fIlibfile.tlib\fR .br Load the package library index of the library file \fBlibfile\fR (which must have the suffix \fI.tlib\fR). Package library indexes along the \fBauto_path\fR are loaded automatically on the first \fBdemand_load\fR; this command is provided to explicitly load libraries that are not in the path. If the index file (with a \fI.tndx\fR suffix) does not exists or is out of date, it will be rebuilt if the user has directory permissions to create it. If a package with the same name as a package in \fIlibfile.tlib\fR has already been loaded, its definition will be overridden by the new package. However, if any procedure has actually been used from the previously defined package, the procedures from \fIlibfile.tlib\fR will not be loaded. '\"@: '\"@:This command is provided by Extended Tcl. '\"@endhelp ' .TP '\"@help: tcl/libraries/auto_packages '\"@brief: List all packages. \fBauto_packages\fR ?\fI\-location\fR? .br Returns a list of the names of all defined packages. If \fI\-location\fR is specified, a list of pairs of package name and the \fB.tlib\fR path name, offset and length of the package within the library. '\"@: '\"@:This procedure is provided by Extended Tcl. '\"@endhelp .TP '\"@help: tcl/libraries/auto_load_file '\"@brief: Search the auto_path for a file to source. \fBauto_load_file\fR \fIfile\fR .br Source a file, as with the \fBsource\fR command, except search \fBauto_path\fR for the file. '\"@: '\"@:This procedure is provided by Extended Tcl. '\"@endhelp ' .TP '\"@help: tcl/libraries/searchpath '\"@brief: Search a path list for a file. \fBsearchpath\fR \fIpath file\fR .br Search all directories in the specified path, which is a Tcl list, for the specified file. Returns the full path name of the file, or an empty string if the requested file could not be found. '\"@: '\"@:This procedure is provided by Extended Tcl. '\"@endhelp tclx8.4-8.4.1.orig/doc/Handles.30000644000000000000000000001320612046313167012771 0ustar .\" .\" Handles.man .\" .\" Extended Tcl handle facility. .\"---------------------------------------------------------------------------- .\" Copyright 1992-1999 Karl Lehenbauer and Mark Diekhans. .\" .\" Permission to use, copy, modify, and distribute this software and its .\" documentation for any purpose and without fee is hereby granted, provided .\" that the above copyright notice appear in all copies. Karl Lehenbauer and .\" Mark Diekhans make no representations about the suitability of this .\" software for any purpose. It is provided "as is" without express or .\" implied warranty. .\"---------------------------------------------------------------------------- .\" $Id: Handles.3,v 8.3 2003/02/09 08:27:59 hobbs Exp $ .\"---------------------------------------------------------------------------- .\" .TH Handles TCL "" "Tcl" .ad b .BS .SH NAME Tcl_HandleAlloc, Tcl_HandleFree, Tcl_HandleTblInit, Tcl_HandleTblRelease, Tcl_HandleTblUseCount, Tcl_HandleWalk, Tcl_HandleXlate \- Dynamic, handle addressable tables. .SH SYNOPSIS .PP .nf .ft CW #include void_pt Tcl_HandleTblInit (const char *handleBase, int entrySize, int initEntries); int Tcl_HandleTblUseCount (void_pt headerPtr, int amount); void Tcl_HandleTblRelease (void_pt headerPtr); void_pt Tcl_HandleAlloc (void_pt headerPtr, char *handlePtr); void_pt Tcl_HandleXlate (Tcl_Interp *interp, void_pt headerPtr, const char *handle); void_pt Tcl_HandleWalk (void_pt headerPtr, int *walkKeyPtr); void Tcl_WalkKeyToHandle (void_pt headerPtr, int walkKey, char *handlePtr); void Tcl_HandleFree (void_pt headerPtr, void_pt entryPtr); .ft R .fi ' .SH DESCRIPTION .PP The Tcl handle facility provides a way to manage table entries that may be referenced by a textual handle from Tcl code. This is provided for applications that need to create data structures in one command, return a reference (i.e. pointer) to that particular data structure and then access that data structure in other commands. An example application is file handles. .PP A handle consists of a base name, which is some unique, meaningful name, such as `\fBfile\fR' and a numeric value appended to the base name (e.g. `file3'). The handle facility is designed to provide a standard mechanism for building Tcl commands that allocate and access table entries based on an entry index. The tables are expanded when needed, consequently pointers to entries should not be kept, as they will become invalid when the table is expanded. If the table entries are large or pointers must be kept to the entries, then the the entries should be allocated separately and pointers kept in the handle table. A use count is kept on the table. This use count is intended to determine when a table shared by multiple commands is to be release. ' .SS Tcl_HandleTblInit Create and initialize a Tcl dynamic handle table. The use count on the table is set to one. .PP Parameters: .RS 2 \fBo \fIhandleBase\fR - The base name of the handle, the handle will be returned in the form "baseNN", where NN is the table entry number. .br \fBo \fIentrySize\fR - The size of an entry, in bytes. .br \fBo \fIinitEntries\fR - Initial size of the table, in entries. .RE .PP Returns: .RS 2 A pointer to the table header. .RE ' .SS Tcl_HandleTblUseCount .PP Alter the handle table use count by the specified amount, which can be positive or negative. Amount may be zero to retrieve the use count. .PP Parameters: .RS 2 \fBo \fIheaderPtr\fR - Pointer to the table header. .br \fBo \fIamount\fR - The amount to alter the use count by. .RE .PP Returns: .RS 2 The resulting use count. .RE ' .SS Tcl_HandleTblRelease .PP Decrement the use count on a Tcl dynamic handle table. If the count goes to zero or negative, then release the table. .PP Parameters: .RS 2 \fBo \fIheaderPtr\fR - Pointer to the table header. .RE ' .SS Tcl_HandleAlloc .PP Allocate an entry and associate a handle with it. .PP Parameters: .RS 2 \fBo \fIheaderPtr\fR - A pointer to the table header. .br \fBo \fIhandlePtr\fR - Buffer to return handle in. It must be big enough to hold the name. .RE .PP Returns: .RS 2 A pointer to the allocated entry (user part). .RE ' .SS Tcl_HandleXlate .PP Translate a handle to a entry pointer. .PP Parameters: .RS 2 \fBo \fIinterp\fR - A error message may be returned in result. .br \fBo \fIheaderPtr\fR - A pointer to the table header. .sp o \fIhandle\fR - The handle assigned to the entry. .RE .PP Returns: .RS 2 A pointer to the entry, or NULL if an error occurred. .RE ' .SS Tcl_HandleWalk .PP Walk through and find every allocated entry in a table. Entries may be deallocated during a walk, but should not be allocated. .PP Parameters: .RS 2 \fBo \fIheaderPtr\fR - A pointer to the table header. .br \fBo \fIwalkKeyPtr\fR - Pointer to a variable to use to keep track of the place in the table. The variable should be initialized to -1 before the first call. .RE Returns: .RS 2 A pointer to the next allocated entry, or NULL if there are not more. .RE ' .SS Tcl_WalkKeyToHandle .PP Convert a walk key, as returned from a call to Tcl_HandleWalk into a handle. The Tcl_HandleWalk must have succeeded. .PP Parameters: .RS 2 \fBo \fIheaderPtr\fR - A pointer to the table header. .br \fBo \fIwalkKey\fR - The walk key. .br \fBo \fIhandlePtr\fR - Buffer to return handle in. It must be big enough to hold the name. .RE ' .SS Tcl_HandleFree .PP Frees a handle table entry. .PP Parameters: .RS 2 \fBo \fIheaderPtr\fR - A pointer to the table header. .br \fBo \fIentryPtr\fR - Entry to free. .RE tclx8.4-8.4.1.orig/doc/Keylist.30000644000000000000000000001025112046313167013034 0ustar .\" .\" Keylist.man .\" .\" Extended Tcl keyed lists commands. .\"---------------------------------------------------------------------------- .\" Copyright 1992-1999 Karl Lehenbauer and Mark Diekhans. .\" .\" Permission to use, copy, modify, and distribute this software and its .\" documentation for any purpose and without fee is hereby granted, provided .\" that the above copyright notice appear in all copies. Karl Lehenbauer and .\" Mark Diekhans make no representations about the suitability of this .\" software for any purpose. It is provided "as is" without express or .\" implied warranty. .\"---------------------------------------------------------------------------- .\" $Id: Keylist.3,v 8.3 1999/03/31 06:37:41 markd Exp $ .\"---------------------------------------------------------------------------- .\" .TH "Tcl_GetKeyedListKeys" TCL "" "Tcl" .ad b .SH NAME TclX_NewKeyedListObj, TclX_KeyedListGet, TclX_KeyedListSet, TclX_KeyedListDelete, TclX_KeyedListGetKeys - Keyed list management routines. .SH SYNOPSIS .PP .nf .ft CW #include Tcl_Obj * TclX_NewKeyedListObj (void); int TclX_KeyedListGet (Tcl_Interp *interp, Tcl_Obj *keylPtr, char *key, Tcl_Obj **valuePtrPtr); int TclX_KeyedListSet (Tcl_Interp *interp, Tcl_Obj *keylPtr, char *key, Tcl_Obj *valuePtr); int TclX_KeyedListDelete (Tcl_Interp *interp, Tcl_Obj *keylPtr, char *key); int TclX_KeyedListGetKeys (Tcl_Interp *interp, Tcl_Obj *keylPtr, char *key, Tcl_Obj **listObjPtrPtr); .ft R .fi ' .SH DESCRIPTION .PP These routines perform operations on keyed lists. See the \fIExtended Tcl\fR man page for a description of keyed lists. .SS TclX_NewKeyedListObj .PP Create and initialize a new keyed list object. .PP Returns: .RS 2 A pointer to the object. .RE ' .SS TclX_KeyedListGet .PP Retrieve a key value from a keyed list. .PP Parameters: .RS 2 \fBo \fIinterp\fR - Error message will be return in result if there is an error. .br \fBo \fIkeylPtr\fR - Keyed list object to get key from. .br \fBo \fIkey\fR - The name of the key to extract. Will recusively process sub-keys seperated by `.'. .br \fBo \fIvalueObjPtrPtr\fR - If the key is found, a pointer to the key object is returned here. NULL is returned if the key is not present. .br .RE .PP Returns: .RS 2 \fBo \fBTCL_OK\fR - If the key value was returned. .br \fBo \fBTCL_BREAK\fR - If the key was not found. .br \fBo \fBTCL_ERROR\fR - If an error occured. .br .RE ' .SS TclX_KeyedListSet .PP Set a key value in keyed list object. .PP Parameters: .RS 2 \fBo \fIinterp\fR - Error message will be return in result object. .br \fBo \fIkeylPtr\fR - Keyed list object to update. .br \fBo \fIkey\fR - The name of the key to extract. Will recusively process sub-key seperated by `.'. .br \fBo \fIvalueObjPtr\fR - The value to set for the key. .br .RE .PP Returns: .RS 2 TCL_OK or TCL_ERROR. .RE ' .SS TclX_KeyedListDelete .PP Delete a key value from keyed list. .PP Parameters: .RS 2 \fBo \fIinterp\fR - Error message will be return in result if there is an error. .br \fBo \fIkeylPtr\fR - Keyed list object to update. .br \fBo \fIkey\fR - The name of the key to extract. Will recusively process sub-key seperated by `.'. .br .RE .PP Returns: .RS 2 \fBo \fBTCL_OK\fR - If the key was deleted. .br \fBo \fBTCL_BREAK\fR - If the key was not found. .br \fBo \fBTCL_ERROR\fR - If an error occured. .br .RE ' .SS TclX_KeyedListGetKeys .PP Retrieve a list of keyed list keys. .PP Parameters: .RS 2 \fBo \fIinterp\fR - Error message will be return in result if there is an error. .br \fBo \fIkeylPtr\fR - Keyed list object to get key from. .br \fBo \fIkey\fR - The name of the key to get the sub keys for. NULL or empty to retrieve all top level keys. .br \fBo \fIlistObjPtrPtr\fR - List object is returned here with key as values. .RE .PP Returns: .RS 2 \fBo \fBTCL_OK\fR - If the zero or more key where returned. .br \fBo \fBTCL_BREAK\fR - If the key was not found. .br \fBo \fBTCL_ERROR\fR - If an error occured. .br .RE ' tclx8.4-8.4.1.orig/doc/TclXInit.30000644000000000000000000001477612046313167013126 0ustar .\" .\" TclXInit.3 .\" .\" Extended Tcl initialization functions. .\"---------------------------------------------------------------------------- .\" Copyright 1992-1999 Karl Lehenbauer and Mark Diekhans. .\" .\" Permission to use, copy, modify, and distribute this software and its .\" documentation for any purpose and without fee is hereby granted, provided .\" that the above copyright notice appear in all copies. Karl Lehenbauer and .\" Mark Diekhans make no representations about the suitability of this .\" software for any purpose. It is provided "as is" without express or .\" implied warranty. .\"---------------------------------------------------------------------------- .\" $Id: TclXInit.3,v 8.2 1999/03/31 06:37:42 markd Exp $ .\"---------------------------------------------------------------------------- .\" .TH "TclXInit" TCL "" "Tcl" .ad b .SH NAME Tclx_Init, Tclxcmd_Init, TclX_Main, Tkx_Init, TkX_Main - Extended Tcl initialization. ' .SH SYNOPSIS .nf .ft CW -ltclx -ltcl #include "tclExtend.h" int Tclx_Init (Tcl_Interp *interp); int Tclxcmd_Init (Tcl_Interp *interp); int void TclX_Main (int argc, char **argv, Tcl_AppInitProc *appInitProc); int Tkx_Init (Tcl_Interp *interp); void TkX_Main (int argc, char **argv, Tcl_AppInitProc *appInitProc); void TclX_SetAppInfo (int defaultValues, char *appName, char *appLongName, char *appVersion, int appPatchlevel); .ft R .fi .SH DESCRIPTION These functions are used to initialize Extended Tcl and applications based on Extended Tcl. This manual page also discusses various issues and approaches of integrating TclX into other applications. ' .SS "Tclx_Init" .PP Initializes Extended Tcl, adding the extended command set to the interpreter. This is called from \fBTcl_AppInit\fR. This function must be called after the \fBTcl_Init\fR function. In addition to the standard command set, it enables use of tlib packages libraries and makes the standard TclX library available. .PP Parameters .RS 2 \fBo \fIinterp\fR - A pointer to the interpreter to add the commands to. .RE .PP Returns: .RS 2 \fBTCL_OK\fR if all is ok, \fBTCL_ERROR\fR if an error occurred. .RE ' .SS "Tclxcmd_Init" .PP Add the TclX command set to the interpreter, with the exception of the TclX library management commands. This is normally called by \fBTclx_Init\fR and should only be used if you don't want the TclX library handling. .PP Parameters .RS 2 \fBo \fIinterp\fR - A pointer to the interpreter to add the commands to. .RE .PP Returns: .RS 2 \fBTCL_OK\fR if all is ok, \fBTCL_ERROR\fR if an error occurred. .RE ' .SS TclX_Main .PP This function parses the command line according to the TclX shell specification (Unix shell compatible). It creates an interpreter and calls the specified function \fBappInitProc\fR to initialize any application specific commands. It then either evaluates the command of script specified on the command line or enters an interactive command loop. This procedure never returns, it exits the process when it's done. Using the TclX shell also gives you SIGINT handling in interactive shells. ' .SS "Tkx_Init" .PP Initializes Extended Tcl Tk environment. This is called from \fBTcl_AppInit\fR after the \fBTk_Init\fR function. .PP Parameters .RS 2 \fBo \fIinterp\fR - A pointer to the interpreter to add the commands to. .RE .PP Returns: .RS 2 \fBTCL_OK\fR if all is ok, \fBTCL_ERROR\fR if an error occurred. .RE ' .SS TkX_Main .PP This function parses the command line according to the wish shell specification. It creates an interpreter and calls the specified function \fBappInitProc\fR to initialize any application specific commands. It then either evaluates the command of script specified on the command line or enters an interactive command loop. This procedure never returns, it exits the process when it's done. Using the TclX wish shell gives you SIGINT handling in interactive shells, otherwise it is identical to standard wish. ' .SS TclX_SetAppInfo .PP Store the application information returned by infox. .PP Parameters .RS 2 \fBo \fIdefaultValues\fR - If true, then the values are assigned only if they are not already defined (defaulted). If false, the values are always set. .br \fBo \fIappName\fR - Application symbolic name. .br \fBo \fIappLongName\fR - Long, natural language application name. .br \fBo \fIappVersion\fR - Version number of the application. .br \fBo \fIappPatchlevel\fR - Patch level of the application. If less than zero, don't change. .RE .PP String pointers are saved without copying, don't release the memory. If the arguments are NULL, don't change the values. ' .SH "DYNAMIC LOADING OF TCLX" .PP TclX can be dynamically loaded on systems that support shared libraries and the load command. This can be done using either the \fBload\fR or the \fBpackage require\fR commands. If \fBpackage require\fR is to be used, a \fBpkgIndex,tcl\fR must be constructed. The \fBpkg_mkIndex\fR does not generate a pkgIndex.tcl file that works with TclX. Instead a command similar to .sp .RS 2 .ft CW package ifneeded Tclx 7.5.0 "load $dir/libtclx.so" .ft R .RE .sp should be placed in the directory containing the TclX shared library. A prototype \fBpkgIndex,tcl\fR file is build by TclX and is installed in the run time directory under the name \fBpkgIndex,proto\fR. This file can't be used as-is, but should be renamed and copied or combined with an existing \fBpkgIndex,tcl\fR in the directory containing the shared library. .PP There is no need to dynamically load \fBlibtkx.so\fR, since it only contains support for \fBwishx\fR. .SH "INTEGRATING TCLX WITH OTHER EXTENSIONS AND APPLICATIONS" .PP The main aspects to integrating TclX with into an application is to decide if the application is based on the standard Tcl/Tk shells or the TclX shells. If the standard shells are desired, then all that is necessary is to call \fBTclx_Init\fR after \fBTcl_Init\fR and \fBTkx_Init\fR after \fBTk_Init\fR. This functionality may also be dynamically loaded. .PP To get the TclX shell in a Tcl only application, with the \fBtcl\fR command functionality, call \fBTclX_Main\fR from the \fBmain\fR function instead of \fBTcl_Main\fR. This shell has arguments conforming to other Unix shells and SIGINT signal handling when interactive,. .PP To get the Tclx shell in a Tk application, with the \fBwishx\fR command functionality, call \fBTkX_Main\fR from the \fBmain\fR function instead of \fBTk_Main\fR. This shell has SIGINT signal handling when interactive, tclx8.4-8.4.1.orig/library/0000755000000000000000000000000012046525461012226 5ustar tclx8.4-8.4.1.orig/library/buildidx.tcl0000644000000000000000000001417712046313166014545 0ustar # # buildidx.tcl -- # # Code to build Tcl package library. Defines the proc `buildpackageindex'. # #------------------------------------------------------------------------------ # Copyright 1992-1999 Karl Lehenbauer and Mark Diekhans. # # Permission to use, copy, modify, and distribute this software and its # documentation for any purpose and without fee is hereby granted, provided # that the above copyright notice appear in all copies. Karl Lehenbauer and # Mark Diekhans make no representations about the suitability of this # software for any purpose. It is provided "as is" without express or # implied warranty. #------------------------------------------------------------------------------ # $Id: buildidx.tcl,v 1.1 2001/10/24 23:31:48 hobbs Exp $ #------------------------------------------------------------------------------ # namespace eval TclX { #-------------------------------------------------------------------------- # The following code passes around a array containing information about a # package. The following fields are defined # # o name - The name of the package. # o offset - The byte offset of the package in the file. # o length - Number of bytes in the current package (EOLN counts as one # byte, even if is used. This makes it possible to do a # single read. # o procs - The list of entry point procedures defined for the package. #-------------------------------------------------------------------------- #-------------------------------------------------------------------------- # Write a line to the index file describing the package. # proc PutIdxEntry {outfp pkgInfo} { puts $outfp [concat [keylget pkgInfo name] \ [keylget pkgInfo offset] \ [keylget pkgInfo length] \ [keylget pkgInfo procs]] } #-------------------------------------------------------------------------- # Parse a package header found by a scan match. Handle backslashed # continuation lines. Make a namespace reference out of the name # that the Tcl auto_load function will like. Global names have no # leading :: (for historic reasons), all others are fully qualified. # proc ParsePkgHeader matchInfoVar { upvar $matchInfoVar matchInfo set length [expr [clength $matchInfo(line)] + 1] set line [string trimright $matchInfo(line)] while {[string match {*\\} $line]} { set line [csubstr $line 0 [expr [clength $line]-1]] set nextLine [gets $matchInfo(handle)] append line " " [string trimright $nextLine] incr length [expr [clength $nextLine] + 1] } set procs {} foreach p [lrange $line 2 end] { lappend procs [auto_qualify $p ::] } keylset pkgInfo name [lindex $line 1] keylset pkgInfo offset $matchInfo(offset) keylset pkgInfo procs $procs keylset pkgInfo length $length return $pkgInfo } #-------------------------------------------------------------------------- # Do the actual work of creating a package library index from a library # file. # proc CreateLibIndex {libName} { if {[file extension $libName] != ".tlib"} { error "Package library `$libName' does not have the extension\ `.tlib'" } set idxName "[file root $libName].tndx" catch {file delete $idxName} set contectHdl [scancontext create] scanmatch $contectHdl "^#@package: " { if {[catch {llength $matchInfo(line)}] || ([llength $matchInfo(line)] < 2)} { error "invalid package header \"$matchInfo(line)\"" } if ![lempty $pkgInfo] { TclX::PutIdxEntry $idxFH $pkgInfo } set pkgInfo [TclX::ParsePkgHeader matchInfo] incr packageCnt } scanmatch $contectHdl "^#@packend" { if [lempty $pkgInfo] { error "#@packend without #@package in $libName" } keylset pkgInfo length \ [expr [keylget pkgInfo length] + \ [clength $matchInfo(line)]+1] TclX::PutIdxEntry $idxFH $pkgInfo set pkgInfo {} } scanmatch $contectHdl { if ![lempty $pkgInfo] { keylset pkgInfo length \ [expr [keylget pkgInfo length] + \ [clength $matchInfo(line)]+1] } } try_eval { set libFH [open $libName r] set idxFH [open $idxName w] set packageCnt 0 set pkgInfo {} scanfile $contectHdl $libFH if {$packageCnt == 0} { error "No \"#@package:\" definitions found in $libName" } if ![lempty $pkgInfo] { TclX::PutIdxEntry $idxFH $pkgInfo } } { catch {file delete $idxName} error $errorResult $errorInfo $errorCode } { catch {close $libFH} catch {close $idxFH} } scancontext delete $contectHdl # Set mode and ownership of the index to be the same as the library. # Ignore errors if you can't set the ownership. # FIX: WIN32, when chmod/chown work. global tcl_platform if ![cequal $tcl_platform(platform) "unix"] return file stat $libName statInfo chmod $statInfo(mode) $idxName catch { chown [list $statInfo(uid) $statInfo(gid)] $idxName } } } ;# namespace TclX #------------------------------------------------------------------------------ # Create a package library index from a library file. # proc buildpackageindex {libfilelist} { foreach libfile $libfilelist { if [catch { TclX::CreateLibIndex $libfile } errmsg] { global errorInfo errorCode error "building package index for `$libfile' failed: $errmsg" \ $errorInfo $errorCode } } } tclx8.4-8.4.1.orig/library/help.tcl0000644000000000000000000002456012046313166013666 0ustar # # help.tcl -- # # Tcl help command. (see TclX manual) # #------------------------------------------------------------------------------ # Copyright 1992-1999 Karl Lehenbauer and Mark Diekhans. # # Permission to use, copy, modify, and distribute this software and its # documentation for any purpose and without fee is hereby granted, provided # that the above copyright notice appear in all copies. Karl Lehenbauer and # Mark Diekhans make no representations about the suitability of this # software for any purpose. It is provided "as is" without express or # implied warranty. #------------------------------------------------------------------------------ # The help facility is based on a hierarchical tree of subjects (directories) # and help pages (files). There is a virtual root to this tree. The root # being the merger of all "help" directories found along the $auto_path # variable. #------------------------------------------------------------------------------ # $Id: help.tcl,v 1.2 2004/11/23 05:54:15 hobbs Exp $ #------------------------------------------------------------------------------ # #@package: TclX-help help helpcd helppwd apropos namespace eval ::tclx { namespace export help helpcd helppwd apropos } namespace eval ::tclx::help { variable curSubject "/" } #------------------------------------------------------------------------------ # Help command. proc ::tclx::help {{what {}}} { variable ::tclx::help::lineCnt 0 # Special case "help help", so we can get it at any level. if {($what == "help") || ($what == "?")} { tclx::help::HelpOnHelp return } set pathList [tclx::help::ConvertPath $what] if {[file isfile [lindex $pathList 0]]} { tclx::help::DisplayPage [lindex $pathList 0] return } tclx::help::ListSubject $what $pathList subjects pages set relativeDir [tclx::help::RelativePath [lindex $pathList 0]] if {[llength $subjects] != 0} { tclx::help::Display "\nSubjects available in $relativeDir:" tclx::help::DisplayColumns $subjects } if {[llength $pages] != 0} { tclx::help::Display "\nHelp pages available in $relativeDir:" tclx::help::DisplayColumns $pages } } #------------------------------------------------------------------------------ # helpcd command. The name of the new current directory is assembled from the # current directory and the argument. proc ::tclx::helpcd {{dir /}} { variable ::tclx::help::curSubject set pathName [lindex [tclx::help::ConvertPath $dir] 0] if {![file isdirectory $pathName]} { error "\"$dir\" is not a subject" [list TCLXHELP NOTSUBJECT $dir] } set ::tclx::help::curSubject [tclx::help::RelativePath $pathName] return } #------------------------------------------------------------------------------ # Helpcd main. proc ::tclx::helppwd {} { variable ::tclx::help::curSubject echo "Current help subject: $::tclx::help::curSubject" } #------------------------------------------------------------------------------ # apropos command. This search the proc ::tclx::apropos {regexp} { variable ::tclx::help::lineCnt 0 variable ::tclx::help::curSubject set ch [scancontext create] scanmatch -nocase $ch $regexp { set path [lindex $matchInfo(line) 0] set desc [lrange $matchInfo(line) 1 end] if {![tclx::help::Display [format "%s - %s" $path $desc]]} { set stop 1 return } } set stop 0 foreach dir [tclx::help::RootDirs] { foreach brief [glob -nocomplain $dir/*.brf] { set briefFH [open $brief] try_eval { scanfile $ch $briefFH } {} { close $briefFH } if {$stop} break } if {$stop} break } scancontext delete $ch } ## ## Private Helper Routines ## #---------------------------------------------------------------------- # Return a list of help root directories. proc ::tclx::help::RootDirs {} { global auto_path set roots {} foreach dir $auto_path { if {[file isdirectory $dir/help]} { lappend roots $dir/help } } return $roots } #-------------------------------------------------------------------------- # Take a path name which might have "." and ".." elements and flatten them # out. Also removes trailing and adjacent "/", unless its the only # character. proc ::tclx::help::FlattenPath pathName { set newPath {} foreach element [split $pathName /] { if {"$element" == "." || [lempty $element]} continue if {"$element" == ".."} { if {[llength [join $newPath /]] == 0} { error "Help: name goes above subject directory root" {} \ [list TCLXHELP NAMEABOVEROOT $pathName] } lvarpop newPath [expr [llength $newPath]-1] continue } lappend newPath $element } set newPath [join $newPath /] # Take care of the case where we started with something line "/" or "/." if {("$newPath" == "") && [string match "/*" $pathName]} { set newPath "/" } return $newPath } #-------------------------------------------------------------------------- # Given a pathName relative to the virtual help root, convert it to a list # of real file paths. A list is returned because the path could be "/", # returning a list of all roots. The list is returned in the same order of # the auto_path variable. If path does not start with a "/", it is take as # relative to the current help subject. Note: The root directory part of # the name is not flattened. This lets other commands pick out the part # relative to the one of the root directories. proc ::tclx::help::ConvertPath pathName { variable curSubject if {![string match "/*" $pathName]} { if {[cequal $curSubject "/"]} { set pathName "/$pathName" } else { set pathName "$curSubject/$pathName" } } set pathName [FlattenPath $pathName] # If the virtual root is specified, return a list of directories. if {$pathName == "/"} { return [RootDirs] } # Not the virtual root find the first match. foreach dir [RootDirs] { if {[file readable $dir/$pathName]} { return [list $dir/$pathName] } } # Not found, try to find a file matching only the file tail, # for example if --> /tcl/control/if. set fileTail [file tail $pathName] foreach dir [RootDirs] { set fileName [exec find $dir -name $fileTail | head -1] if {$fileName != {}} { return [list $fileName] } } error "\"$pathName\" does not exist" {} \ [list TCLXHELP NOEXIST $pathName] } #-------------------------------------------------------------------------- # Return the virtual root relative name of the file given its absolute # path. The root part of the path should not have been flattened, as we # would not be able to match it. proc ::tclx::help::RelativePath pathName { foreach dir [RootDirs] { if {[csubstr $pathName 0 [clength $dir]] == $dir} { set name [csubstr $pathName [clength $dir] end] if {$name == ""} {set name /} return $name } } if {![info exists found]} { error "problem translating \"$pathName\"" {} [list TCLXHELP INTERROR] } } #-------------------------------------------------------------------------- # Given a list of path names to subjects generated by ConvertPath, return # the contents of the subjects. Two lists are returned, subjects under # that subject and a list of pages under the subject. Both lists are # returned sorted. This merges all the roots into a virtual root. # pathName is the string that was passed to ConvertPath and is used for # error reporting. *.brk files are not returned. proc ::tclx::help::ListSubject {pathName pathList subjectsVar pagesVar} { upvar $subjectsVar subjects $pagesVar pages set subjects {} set pages {} set foundDir 0 foreach dir $pathList { if {![file isdirectory $dir] || [cequal [file tail $dir] CVS]} continue set foundDir 1 foreach file [glob -nocomplain $dir/*] { if {[lsearch {.brf .orig .diff .rej} [file extension $file]] \ >= 0} continue if [file isdirectory $file] { lappend subjects [file tail $file]/ } else { lappend pages [file tail $file] } } } if {!$foundDir} { if {[cequal $pathName /]} { global auto_path error "no \"help\" directories found on auto_path ($auto_path)" {} \ [list TCLXHELP NOHELPDIRS] } else { error "\"$pathName\" is not a subject" {} \ [list TCLXHELP NOTSUBJECT $pathName] } } set subjects [lsort $subjects] set pages [lsort $pages] return {} } #-------------------------------------------------------------------------- # Display a line of output, pausing waiting for input before displaying if # the screen size has been reached. Return 1 if output is to continue, # return 0 if no more should be outputed, indicated by input other than # return. # proc ::tclx::help::Display line { variable lineCnt if {$lineCnt >= 23} { set lineCnt 0 puts -nonewline stdout ":" flush stdout gets stdin response if {![lempty $response]} { return 0} } puts stdout $line incr lineCnt } #-------------------------------------------------------------------------- # Display a help page (file). proc ::tclx::help::DisplayPage filePath { set inFH [open $filePath r] try_eval { while {[gets $inFH fileBuf] >= 0} { if {![Display $fileBuf]} { break } } } {} { close $inFH } } #-------------------------------------------------------------------------- # Display a list of file names in a column format. This use columns of 14 # characters 3 blanks. proc ::tclx::help::DisplayColumns {nameList} { set count 0 set outLine "" foreach name $nameList { if {$count == 0} { append outLine " " } append outLine $name if {[incr count] < 4} { set padLen [expr 17-[clength $name]] if {$padLen < 3} { set padLen 3} append outLine [replicate " " $padLen] } else { if {![Display $outLine]} { return} set outLine "" set count 0 } } if {$count != 0} { Display [string trimright $outLine]} return } #-------------------------------------------------------------------------- # Display help on help, the first occurance of a help page called "help" in # the help root. proc ::tclx::help::HelpOnHelp {} { set helpPage [lindex [ConvertPath /help] 0] if {[lempty $helpPage]} { error "No help page on help found" {} \ [list TCLXHELP NOHELPPAGE] } DisplayPage $helpPage } tclx8.4-8.4.1.orig/library/forfile.tcl0000644000000000000000000000263112046313166014357 0ustar # # forfile.tcl -- # # Proc to execute code on every line of a file. #------------------------------------------------------------------------------ # Copyright 1992-1999 Karl Lehenbauer and Mark Diekhans. # # Permission to use, copy, modify, and distribute this software and its # documentation for any purpose and without fee is hereby granted, provided # that the above copyright notice appear in all copies. Karl Lehenbauer and # Mark Diekhans make no representations about the suitability of this # software for any purpose. It is provided "as is" without express or # implied warranty. #------------------------------------------------------------------------------ # $Id: forfile.tcl,v 1.1 2001/10/24 23:31:48 hobbs Exp $ #------------------------------------------------------------------------------ # #@package: TclX-forfile for_file proc for_file {var filename cmd} { upvar 1 $var line set fp [open $filename r] try_eval { set code 0 set result {} while {[gets $fp line] >= 0} { set code [catch {uplevel 1 $cmd} result] if {$code != 0 && $code != 4} break } } {} { close $fp } if {$code == 0 || $code == 3 || $code == 4} { return $result } if {$code == 1} { global errorCode errorInfo return -code $code -errorcode $errorCode -errorinfo $errorInfo $result } return -code $code $result } tclx8.4-8.4.1.orig/library/tclx.tcl0000644000000000000000000000406012046313166013701 0ustar #----------------------------------------------------------------------------- # tclx.tcl -- Extended Tcl initialization. #----------------------------------------------------------------------------- # $Id: tclx.tcl,v 1.6 2005/11/21 18:37:58 hobbs Exp $ #----------------------------------------------------------------------------- namespace eval ::tclx { global auto_path auto_index tclx_library if {[info exists tclx_library] && [string length $tclx_library]} { set auto_index(buildpackageindex) \ {source [file join $tclx_library buildidx.tcl]} if {![info exists auto_path] || [lsearch -exact $auto_path $tclx_library] == -1} { lappend auto_path $tclx_library } } variable file "" variable dir "" variable libfiles array set libfiles { arrayprocs.tcl 1 autoload.tcl 0 buildhelp.tcl 0 buildidx.tcl 0 compat.tcl 1 convlib.tcl 1 edprocs.tcl 1 events.tcl 1 fmath.tcl 1 forfile.tcl 1 globrecur.tcl 1 help.tcl 1 profrep.tcl 1 pushd.tcl 1 setfuncs.tcl 1 showproc.tcl 1 stringfile.tcl 1 tcllib.tcl 0 tclx.tcl 0 } set dir [file dirname [info script]] foreach file [array names libfiles] { if {$libfiles($file)} { uplevel \#0 [list source [file join $dir $file]] } } if 0 { # A pure Tcl equivalent to TclX's readdir, except that it includes # . and .., which should be removed proc ::readdir {args} { set len [llength $args] set ptn [list *] if {![string equal $::tcl_platform(platform) "windows"]} { lappend ptn .* } if {$len == 1} { set dir [lindex $args 0] } elseif {$len == 2} { if {![string equal [lindex $args 0] "-hidden"]} { return -code error \ "expected option of \"-hidden\", got \"[lindex $args 0]\"" } if {[string equal $::tcl_platform(platform) "windows"]} { lappend ptn .* } set dir [lindex $args 1] } else { set cmd [lindex [info level 0] 0] return -code error \ "wrong \# args: $cmd ?-hidden? dirPath" } return [eval [list glob -tails -nocomplain -directory $dir] $ptn] } } }; # end namespace tclx tclx8.4-8.4.1.orig/library/globrecur.tcl0000644000000000000000000000615712046313166014724 0ustar # # globrecur.tcl -- # # Build or process a directory list recursively. #------------------------------------------------------------------------------ # Copyright 1992-1999 Karl Lehenbauer and Mark Diekhans. # # Permission to use, copy, modify, and distribute this software and its # documentation for any purpose and without fee is hereby granted, provided # that the above copyright notice appear in all copies. Karl Lehenbauer and # Mark Diekhans make no representations about the suitability of this # software for any purpose. It is provided "as is" without express or # implied warranty. #------------------------------------------------------------------------------ # $Id: globrecur.tcl,v 1.1 2001/10/24 23:31:48 hobbs Exp $ #------------------------------------------------------------------------------ # #@package: TclX-globrecur recursive_glob proc recursive_glob {dirlist globlist} { set result {} set recurse {} foreach dir $dirlist { if ![file isdirectory $dir] { error "\"$dir\" is not a directory" } foreach pattern $globlist { set result [concat $result \ [glob -nocomplain -- [file join $dir $pattern]]] } foreach file [readdir $dir] { set file [file join $dir $file] if [file isdirectory $file] { set fileTail [file tail $file] if {!([cequal $fileTail .] || [cequal $fileTail ..])} { lappend recurse $file } } } } if ![lempty $recurse] { set result [concat $result [recursive_glob $recurse $globlist]] } return $result } #@package: TclX-forrecur for_recursive_glob proc for_recursive_glob {var dirlist globlist cmd {depth 1}} { upvar $depth $var myVar set recurse {} foreach dir $dirlist { if ![file isdirectory $dir] { error "\"$dir\" is not a directory" } set code 0 set result {} foreach pattern $globlist { foreach file [glob -nocomplain -- [file join $dir $pattern]] { set myVar $file set code [catch {uplevel $depth $cmd} result] if {$code != 0 && $code != 4} break } if {$code != 0 && $code != 4} break } if {$code != 0 && $code != 4} { if {$code == 3} { return $result } if {$code == 1} { global errorCode errorInfo return -code $code -errorcode $errorCode \ -errorinfo $errorInfo $result } return -code $code $result } foreach file [readdir $dir] { set file [file join $dir $file] if [file isdirectory $file] { set fileTail [file tail $file] if {!([cequal $fileTail .] || [cequal $fileTail ..])} { lappend recurse $file } } } } if ![lempty $recurse] { return [for_recursive_glob $var $recurse $globlist $cmd \ [expr $depth + 1]] } return {} } tclx8.4-8.4.1.orig/library/setfuncs.tcl0000644000000000000000000000565412046313166014573 0ustar # # setfuncs -- # # Perform set functions on lists. Also has a procedure for removing duplicate # list entries. #------------------------------------------------------------------------------ # Copyright 1992-1999 Karl Lehenbauer and Mark Diekhans. # # Permission to use, copy, modify, and distribute this software and its # documentation for any purpose and without fee is hereby granted, provided # that the above copyright notice appear in all copies. Karl Lehenbauer and # Mark Diekhans make no representations about the suitability of this # software for any purpose. It is provided "as is" without express or # implied warranty. #------------------------------------------------------------------------------ # $Id: setfuncs.tcl,v 1.1 2001/10/24 23:31:48 hobbs Exp $ #------------------------------------------------------------------------------ # #@package: TclX-set_functions union intersect intersect3 lrmdups # # return the logical union of two lists, removing any duplicates # proc union {lista listb} { return [lrmdups [concat $lista $listb]] } # # sort a list, returning the sorted version minus any duplicates # proc lrmdups list { if [lempty $list] { return {} } set list [lsort $list] set last [lvarpop list] lappend result $last foreach element $list { if ![cequal $last $element] { lappend result $element set last $element } } return $result } # # intersect3 - perform the intersecting of two lists, returning a list # containing three lists. The first list is everything in the first # list that wasn't in the second, the second list contains the intersection # of the two lists, the third list contains everything in the second list # that wasn't in the first. # proc intersect3 {list1 list2} { set la1(0) {} ; unset la1(0) set lai(0) {} ; unset lai(0) set la2(0) {} ; unset la2(0) foreach v $list1 { set la1($v) {} } foreach v $list2 { set la2($v) {} } foreach elem [concat $list1 $list2] { if {[info exists la1($elem)] && [info exists la2($elem)]} { unset la1($elem) unset la2($elem) set lai($elem) {} } } list [lsort [array names la1]] [lsort [array names lai]] \ [lsort [array names la2]] } # # intersect - perform an intersection of two lists, returning a list # containing every element that was present in both lists # proc intersect {list1 list2} { set intersectList "" set list1 [lsort $list1] set list2 [lsort $list2] while {1} { if {[lempty $list1] || [lempty $list2]} break set compareResult [string compare [lindex $list1 0] [lindex $list2 0]] if {$compareResult < 0} { lvarpop list1 continue } if {$compareResult > 0} { lvarpop list2 continue } lappend intersectList [lvarpop list1] lvarpop list2 } return $intersectList } tclx8.4-8.4.1.orig/library/buildhelp.tcl0000644000000000000000000003715412046313166014711 0ustar # # buildhelp.tcl -- # # Program to extract help files from TCL manual pages or TCL script files. # The help directories are built as a hierarchical tree of subjects and help # files. # #------------------------------------------------------------------------------ # Copyright 1992-1999 Karl Lehenbauer and Mark Diekhans. # # Permission to use, copy, modify, and distribute this software and its # documentation for any purpose and without fee is hereby granted, provided # that the above copyright notice appear in all copies. Karl Lehenbauer and # Mark Diekhans make no representations about the suitability of this # software for any purpose. It is provided "as is" without express or # implied warranty. #------------------------------------------------------------------------------ # $Id: buildhelp.tcl,v 1.3 2005/03/25 19:32:48 hobbs Exp $ #------------------------------------------------------------------------------ # # For nroff man pages, the areas of text to extract are delimited with: # # '\"@help: subjectdir/helpfile # '\"@endhelp # # start in column one. The text between these markers is extracted and stored # in help/subjectdir/help. The file must not exists, this is done to enforced # cleaning out the directories before help file generation is started, thus # removing any stale files. The extracted text is run through: # # nroff -man|col -xb {col -b on BSD derived systems} # # If there is other text to include in the helpfile, but not in the manual # page, the text, along with nroff formatting commands, may be included using: # # '\"@:Other text to include in the help page. # # A entry in the brief file, used by apropos my be included by: # # '\"@brief: Short, one line description # # These brief request must occur with in the bounds of a help section. # # If some header text, such as nroff macros, need to be preappended to the # text streem before it is run through nroff, then that text can be bracketed # with: # # '\"@header # '\"@endheader # # If multiple header blocks are encountered, they will all be preappended. # # For TCL script files, which are indentified because they end in ".tcl", # the text to be extracted is delimited by: # # #@help: subjectdir/helpfile # #@endhelp # # And brief lines are in the form: # # #@brief: Short, one line description # # The only processing done on text extracted from .tcl files it to replace # the # in column one with a space. # # #----------------------------------------------------------------------------- # # To generate help: # # buildhelp helpDir brief.brf filelist # # o helpDir is the help tree root directory. helpDir should exists, but any # subdirectories that don't exists will be created. helpDir should be # cleaned up before the start of manual page generation, as this program # will not overwrite existing files. # o brief.brf is the name of the brief file to create form the @brief entries. # It must have an extension of ".brf". It will be created in helpDir. # o filelist are the nroff manual pages, or .tcl, .tlib files to extract # the help files from. If the suffix is not .tcl or .tlib, a nroff manual # page is assumed. # #----------------------------------------------------------------------------- #@package: TclX-buildhelp buildhelp #----------------------------------------------------------------------------- # Truncate a file name of a help file if the system does not support long # file names. If the name starts with `Tcl_', then this prefix is removed. # If the name is then over 14 characters, it is truncated to 14 charactes # proc TruncFileName {pathName} { global truncFileNames if {!$truncFileNames} { return $pathName} set fileName [file tail $pathName] if {"[crange $fileName 0 3]" == "Tcl_"} { set fileName [crange $fileName 4 end]} set fileName [crange $fileName 0 13] return "[file dirname $pathName]/$fileName" } #----------------------------------------------------------------------------- # Proc to ensure that all directories for the specified file path exists, # and if they don't create them. Don't use -path so we can set the # permissions. proc EnsureDirs {filePath} { set dirPath [file dirname $filePath] if [file exists $dirPath] return foreach dir [split $dirPath /] { lappend dirList $dir set partPath [join $dirList /] if [file exists $partPath] continue mkdir $partPath chmod u=rwx,go=rx $partPath } } #----------------------------------------------------------------------------- # Proc to set up scan context for use by FilterNroffManPage. # This keeps the a two line cache of the previous two lines encountered # and the blank lines that followed them. # proc CreateFilterNroffManPageContext {} { global filterNroffManPageContext set filterNroffManPageContext [scancontext create] # On finding a page header, drop the previous line (which is # the page footer). Also deleting the blank lines followin # the last line on the previous page. scanmatch $filterNroffManPageContext {@@@BUILDHELP@@@} { catch {unset prev2Blanks} catch {unset prev1Line} catch {unset prev1Blanks} set nukeBlanks {} } # Save blank lines scanmatch $filterNroffManPageContext {$^} { if ![info exists nukeBlanks] { append prev1Blanks \n } } # Non-blank line, save it. Output the 2nd previous line if necessary. scanmatch $filterNroffManPageContext { catch {unset nukeBlanks} if [info exists prev2Line] { puts $outFH $prev2Line unset prev2Line } if [info exists prev2Blanks] { puts $outFH $prev2Blanks nonewline unset prev2Blanks } if [info exists prev1Line] { set prev2Line $prev1Line } set prev1Line $matchInfo(line) if [info exists prev1Blanks] { set prev2Blanks $prev1Blanks unset prev1Blanks } } } #----------------------------------------------------------------------------- # Proc to filter a formatted manual page, removing the page headers and # footers. This relies on each manual page having a .TH macro in the form: # .TH @@@BUILDHELP@@@ n proc FilterNroffManPage {inFH outFH} { global filterNroffManPageContext if ![info exists filterNroffManPageContext] { CreateFilterNroffManPageContext } scanfile $filterNroffManPageContext $inFH if [info exists prev2Line] { puts $outFH $prev2Line } } #----------------------------------------------------------------------------- # Proc to set up scan context for use by ExtractNroffHeader # proc CreateExtractNroffHeaderContext {} { global extractNroffHeaderContext set extractNroffHeaderContext [scancontext create] scanmatch $extractNroffHeaderContext {'\\"@endheader[ ]*$} { break } scanmatch $extractNroffHeaderContext {'\\"@:} { append nroffHeader "[crange $matchInfo(line) 5 end]\n" } scanmatch $extractNroffHeaderContext { append nroffHeader "$matchInfo(line)\n" } } #----------------------------------------------------------------------------- # Proc to extract nroff text to use as a header to all pass to nroff when # processing a help file. # manPageFH - The file handle of the manual page. # proc ExtractNroffHeader {manPageFH} { global extractNroffHeaderContext nroffHeader if ![info exists extractNroffHeaderContext] { CreateExtractNroffHeaderContext } scanfile $extractNroffHeaderContext $manPageFH } #----------------------------------------------------------------------------- # Proc to set up scan context for use by ExtractNroffHelp # proc CreateExtractNroffHelpContext {} { global extractNroffHelpContext set extractNroffHelpContext [scancontext create] scanmatch $extractNroffHelpContext {^'\\"@endhelp[ ]*$} { break } scanmatch $extractNroffHelpContext {^'\\"@brief:} { if $foundBrief { error {Duplicate "@brief:" entry} } set foundBrief 1 puts $briefHelpFH "$helpName\t[csubstr $matchInfo(line) 11 end]" continue } scanmatch $extractNroffHelpContext {^'\\"@:} { puts $nroffFH [csubstr $matchInfo(line) 5 end] continue } scanmatch $extractNroffHelpContext {^'\\"@help:} { error {"@help" found within another help section"} } scanmatch $extractNroffHelpContext { puts $nroffFH $matchInfo(line) } } #----------------------------------------------------------------------------- # Proc to extract a nroff help file when it is located in the text. # manPageFH - The file handle of the manual page. # manLine - The '\"@help: line starting the data to extract. # proc ExtractNroffHelp {manPageFH manLine} { global helpDir nroffHeader briefHelpFH colArgs global extractNroffHelpContext if ![info exists extractNroffHelpContext] { CreateExtractNroffHelpContext } set helpName [string trim [csubstr $manLine 9 end]] set helpFile [TruncFileName "$helpDir/$helpName"] if [file exists $helpFile] { error "Help file already exists: $helpFile" } EnsureDirs $helpFile set tmpFile "[file dirname $helpFile]/tmp.[id process]" echo " creating help file $helpName" set nroffFH [open "| nroff -man | col $colArgs > $tmpFile" w] puts $nroffFH {.TH @@@BUILDHELP@@@ 1} set foundBrief 0 scanfile $extractNroffHelpContext $manPageFH # Close returns an error on if anything comes back on stderr, even if # its a warning. Output errors and continue. set stat [catch { close $nroffFH } msg] if $stat { puts stderr "nroff: $msg" } set tmpFH [open $tmpFile r] set helpFH [open $helpFile w] FilterNroffManPage $tmpFH $helpFH close $tmpFH close $helpFH unlink $tmpFile chmod a-w,a+r $helpFile } #----------------------------------------------------------------------------- # Proc to set up scan context for use by ExtractScriptHelp # proc CreateExtractScriptHelpContext {} { global extractScriptHelpContext set extractScriptHelpContext [scancontext create] scanmatch $extractScriptHelpContext {^#@endhelp[ ]*$} { break } scanmatch $extractScriptHelpContext {^#@brief:} { if $foundBrief { error {Duplicate "@brief" entry} } set foundBrief 1 puts $briefHelpFH "$helpName\t[csubstr $matchInfo(line) 9 end]" continue } scanmatch $extractScriptHelpContext {^#@help:} { error {"@help" found within another help section"} } scanmatch $extractScriptHelpContext {^#$} { puts $helpFH "" } scanmatch $extractScriptHelpContext { if {[clength $matchInfo(line)] > 1} { puts $helpFH " [csubstr $matchInfo(line) 1 end]" } else { puts $helpFH $matchInfo(line) } } } #----------------------------------------------------------------------------- # Proc to extract a tcl script help file when it is located in the text. # ScriptPageFH - The file handle of the .tcl file. # ScriptLine - The #@help: line starting the data to extract. # proc ExtractScriptHelp {scriptPageFH scriptLine} { global helpDir briefHelpFH global extractScriptHelpContext if ![info exists extractScriptHelpContext] { CreateExtractScriptHelpContext } set helpName [string trim [csubstr $scriptLine 7 end]] set helpFile "$helpDir/$helpName" if {[file exists $helpFile]} { error "Help file already exists: $helpFile" } EnsureDirs $helpFile echo " creating help file $helpName" set helpFH [open $helpFile w] set foundBrief 0 scanfile $extractScriptHelpContext $scriptPageFH close $helpFH chmod a-w,a+r $helpFile } #----------------------------------------------------------------------------- # Proc to scan a nroff manual file looking for the start of a help text # sections and extracting those sections. # pathName - Full path name of file to extract documentation from. # proc ProcessNroffFile {pathName} { global nroffScanCT scriptScanCT nroffHeader set fileName [file tail $pathName] set nroffHeader {} set manPageFH [open $pathName r] set matchInfo(fileName) [file tail $pathName] echo " scanning $pathName" scanfile $nroffScanCT $manPageFH close $manPageFH } #----------------------------------------------------------------------------- # Proc to scan a Tcl script file looking for the start of a # help text sections and extracting those sections. # pathName - Full path name of file to extract documentation from. # proc ProcessTclScript {pathName} { global scriptScanCT nroffHeader set scriptFH [open "$pathName" r] set matchInfo(fileName) [file tail $pathName] echo " scanning $pathName" scanfile $scriptScanCT $scriptFH close $scriptFH } #----------------------------------------------------------------------------- # build: main procedure. Generates help from specified files. # helpDirPath - Directory were the help files go. # briefFile - The name of the brief file to create. # sourceFiles - List of files to extract help files from. proc buildhelp {helpDirPath briefFile sourceFiles} { global helpDir truncFileNames nroffScanCT global scriptScanCT briefHelpFH colArgs echo "" echo "Begin building help tree" # Determine version of col command to use (no -x on BSD) if {[catch {exec col -bx /dev/null 2>/dev/null}]} { set colArgs {-b} } else { set colArgs {-bx} } set helpDir $helpDirPath if {![file exists $helpDir]} { mkdir $helpDir } if {![file isdirectory $helpDir]} { error "$helpDir is not a directory or does not exist.\n \ This should be the help root directory" } set status [catch {set tmpFH [open $helpDir/AVeryVeryBigFileName w]}] if {$status != 0} { set truncFileNames 1 } else { close $tmpFH unlink $helpDir/AVeryVeryBigFileName set truncFileNames 0 } set nroffScanCT [scancontext create] scanmatch $nroffScanCT {'\\"@help:} { ExtractNroffHelp $matchInfo(handle) $matchInfo(line) continue } scanmatch $nroffScanCT {^'\\"@header} { ExtractNroffHeader $matchInfo(handle) continue } scanmatch $nroffScanCT {^'\\"@endhelp} { error [concat {@endhelp" without corresponding "@help:"} \ ", offset = $matchInfo(offset)"] } scanmatch $nroffScanCT {^'\\"@brief} { error [concat {"@brief" without corresponding "@help:"} \ ", offset = $matchInfo(offset)"] } set scriptScanCT [scancontext create] scanmatch $scriptScanCT {^#@help:} { ExtractScriptHelp $matchInfo(handle) $matchInfo(line) } if {[file extension $briefFile] != ".brf"} { error "Brief file \"$briefFile\" must have an extension \".brf\"" } if [file exists $helpDir/$briefFile] { error "Brief file \"$helpDir/$briefFile\" already exists" } set briefHelpFH [open "|sort > $helpDir/$briefFile" w] foreach manFile [glob $sourceFiles] { set ext [file extension $manFile] if {$ext == ".tcl" || $ext == ".tlib"} { set status [catch {ProcessTclScript $manFile} msg] } else { set status [catch {ProcessNroffFile $manFile} msg] } if {$status != 0} { global errorInfo errorCode error "Error extracting help from: $manFile" $errorInfo $errorCode } } close $briefHelpFH chmod a-w,a+r $helpDir/$briefFile echo "Completed extraction of help files" } tclx8.4-8.4.1.orig/library/edprocs.tcl0000644000000000000000000000371512046313166014374 0ustar # # edprocs.tcl -- # # Tools for Tcl developers. Procedures to save procs to a file and to edit # a proc in memory. #------------------------------------------------------------------------------ # Copyright 1992-1999 Karl Lehenbauer and Mark Diekhans. # # Permission to use, copy, modify, and distribute this software and its # documentation for any purpose and without fee is hereby granted, provided # that the above copyright notice appear in all copies. Karl Lehenbauer and # Mark Diekhans make no representations about the suitability of this # software for any purpose. It is provided "as is" without express or # implied warranty. #------------------------------------------------------------------------------ # $Id: edprocs.tcl,v 1.2 2004/11/23 00:35:20 hobbs Exp $ #------------------------------------------------------------------------------ # #@package: TclX-developer_utils saveprocs edprocs proc saveprocs {fileName args} { set fp [open $fileName w] try_eval { puts $fp "# tcl procs saved on [fmtclock [getclock]]\n" puts $fp [eval "showproc $args"] } {} { close $fp } } proc edprocs {args} { global env set tmpFilename /tmp/tcldev.[pid].[clock seconds] set access [list RDWR CREAT EXCL TRUNC] set perm 0600 if {[catch {open $tmpFilename $access $perm} fp]} { # something went wrong return -code error "Could not open temporary file:\n$fp" } try_eval { puts $fp "\n# TEMP EDIT BUFFER -- YOUR CHANGES ARE FOR THIS SESSION ONLY\n" puts $fp [eval [linsert $args 0 showproc]] } {} { close $fp } if {[info exists env(EDITOR)]} { set editor $env(EDITOR) } else { set editor vi } set startMtime [file mtime $tmpFilename] system "$editor $tmpFilename" if {[file mtime $tmpFilename] != $startMtime} { source $tmpFilename echo "Procedures were reloaded." } else { echo "No changes were made." } unlink $tmpFilename return } tclx8.4-8.4.1.orig/library/tcllib.tcl0000644000000000000000000001051212046313166014177 0ustar # # tcllib.tcl -- # # Various command dealing with tlib package libraries. #------------------------------------------------------------------------------ # Copyright 1992-1999 Karl Lehenbauer and Mark Diekhans. # # Permission to use, copy, modify, and distribute this software and its # documentation for any purpose and without fee is hereby granted, provided # that the above copyright notice appear in all copies. Karl Lehenbauer and # Mark Diekhans make no representations about the suitability of this # software for any purpose. It is provided "as is" without express or # implied warranty. #------------------------------------------------------------------------------ # Copyright (c) 1991-1994 The Regents of the University of California. # All rights reserved. # # Permission is hereby granted, without written agreement and without # license or royalty fees, to use, copy, modify, and distribute this # software and its documentation for any purpose, provided that the # above copyright notice and the following two paragraphs appear in # all copies of this software. # # IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR # DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT # OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF # CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. # # THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, # INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY # AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS # ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO # PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. #------------------------------------------------------------------------------ # $Id: tcllib.tcl,v 1.1 2001/10/24 23:31:48 hobbs Exp $ #------------------------------------------------------------------------------ # #@package: TclX-libraries searchpath auto_load_file #------------------------------------------------------------------------------ # searchpath: # Search a path list for a file. (catch is for bad ~user) # proc searchpath {pathlist file} { foreach dir $pathlist { if {$dir == ""} {set dir .} if {[catch {file exists $dir/$file} result] == 0 && $result} { return $dir/$file } } return {} } #------------------------------------------------------------------------------ # auto_load_file: # Search auto_path for a file and source it. # proc auto_load_file {name} { global auto_path errorCode if {[string first / $name] >= 0} { return [uplevel 1 source $name] } set where [searchpath $auto_path $name] if [lempty $where] { error "couldn't find $name in any directory in auto_path" } uplevel 1 source $where } #@package: TclX-lib-list auto_packages auto_commands #------------------------------------------------------------------------------ # auto_packages: # List all of the loadable packages. If -files is specified, the file paths # of the packages is also returned. proc auto_packages {{option {}}} { global auto_pkg_index auto_load ;# Make sure all indexes are loaded. if ![info exists auto_pkg_index] { return {} } set packList [array names auto_pkg_index] if [lempty $option] { return $packList } if {$option != "-files"} { error "Unknow option \"$option\", expected \"-files\"" } set locList {} foreach pack $packList { lappend locList [list $pack [lindex $auto_pkg_index($pack) 0]] } return $locList } #------------------------------------------------------------------------------ # auto_commands: # List all of the loadable commands. If -loaders is specified, the commands # that will be involked to load the commands is also returned. proc auto_commands {{option {}}} { global auto_index auto_load ;# Make sure all indexes are loaded. if ![info exists auto_index] { return {} } set cmdList [array names auto_index] if [lempty $option] { return $cmdList } if {$option != "-loaders"} { error "Unknow option \"$option\", expected \"-loaders\"" } set loadList {} foreach cmd $cmdList { lappend loadList [list $cmd $auto_index($cmd)] } return $loadList } tclx8.4-8.4.1.orig/library/autoload.tcl0000644000000000000000000000434012046313166014540 0ustar # # Modified version of the standard Tcl auto_load_index proc that calls a TclX # command load TclX .tndx library indices. # # $Id: autoload.tcl,v 1.2 2002/04/02 03:00:14 hobbs Exp $ # from Tcl: init.tcl,v 1.1.2.4 1998/12/02 20:08:05 welch Exp # # init.tcl -- # # Default system startup file for Tcl-based applications. Defines # "unknown" procedure and auto-load facilities. # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994-1996 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # auto_load_index -- # Loads the contents of tclIndex files on the auto_path directory # list. This is usually invoked within auto_load to load the index # of available commands. Returns 1 if the index is loaded, and 0 if # the index is already loaded and up to date. # # Arguments: # None. proc auto_load_index {} { global auto_index auto_oldpath auto_path errorInfo errorCode if {[info exists auto_oldpath] && ($auto_oldpath == $auto_path)} { return 0 } set auto_oldpath $auto_path # Check if we are a safe interpreter. In that case, we support only # newer format tclIndex files. set issafe [interp issafe] for {set i [expr {[llength $auto_path] - 1}]} {$i >= 0} {incr i -1} { set dir [lindex $auto_path $i] tclx_load_tndxs $dir set f "" if {$issafe} { catch {source [file join $dir tclIndex]} } elseif {[catch {set f [open [file join $dir tclIndex]]}]} { continue } else { set error [catch { set id [gets $f] if {$id == "# Tcl autoload index file, version 2.0"} { eval [read $f] } elseif {$id == \ "# Tcl autoload index file: each line identifies a Tcl"} { while {[gets $f line] >= 0} { if {([string index $line 0] == "#") || ([llength $line] != 2)} { continue } set name [lindex $line 0] set auto_index($name) \ "source [file join $dir [lindex $line 1]]" } } else { error \ "[file join $dir tclIndex] isn't a proper Tcl index file" } } msg] if {[string compare $f ""]} { close $f } if {$error} { error $msg $errorInfo $errorCode } } } return 1 } tclx8.4-8.4.1.orig/library/compat.tcl0000644000000000000000000002346512046313166014224 0ustar # # compat -- # # This file provides commands compatible with older versions of Extended Tcl. # #------------------------------------------------------------------------------ # Copyright 1992-1999 Karl Lehenbauer and Mark Diekhans. # # Permission to use, copy, modify, and distribute this software and its # documentation for any purpose and without fee is hereby granted, provided # that the above copyright notice appear in all copies. Karl Lehenbauer and # Mark Diekhans make no representations about the suitability of this # software for any purpose. It is provided "as is" without express or # implied warranty. #------------------------------------------------------------------------------ # $Id: compat.tcl,v 1.1 2001/10/24 23:31:48 hobbs Exp $ #------------------------------------------------------------------------------ # #@package: TclX-GenCompat assign_fields cexpand proc assign_fields {list args} { puts stderr {**** Your program is using an obsolete TclX proc, "assign_fields".} puts stderr {**** Please use the command "lassign". Compatibility support will} puts stderr {**** be removed in the next release.} proc assign_fields {list args} { if [lempty $args] { return } return [uplevel lassign [list $list] $args] } return [uplevel assign_fields [list $list] $args] } # Added TclX 7.4a proc cexpand str {subst -nocommands -novariables $str} #@package: TclX-ServerCompat server_open server_connect server_send \ server_info server_cntl # Added TclX 7.4a proc server_open args { set cmd server_connect set buffered 1 while {[string match -* [lindex $args 0]]} { set opt [lvarpop args] if [cequal $opt -buf] { set buffered 1 } elseif [cequal $opt -nobuf] { set buffered 0 } lappend cmd $opt } set handle [uplevel [concat $cmd $args]] if $buffered { lappend handle [dup $handle] } return $handle } # Added TclX 7.5a proc server_connect args { set cmd socket set buffered 1 set twoids 0 while {[string match -* [lindex $args 0]]} { switch -- [set opt [lvarpop args]] { -buf { set buffered 1 } -nobuf { set buffered 0 } -myip { lappend cmd -myaddr [lvarpop args] } -myport { lappend cmd -myport [lvarpop args] } -twoids { set twoids 1 } default { error "unknown option \"$opt\"" } } } set handle [uplevel [concat $cmd $args]] if !$buffered { fconfigure $handle -buffering none } if $twoids { lappend handle [dup $handle] } return $handle } proc server_send args { set cmd puts while {[string match -* [lindex $args 0]]} { switch -- [set opt [lvarpop args]] { {-dontroute} { error "server_send if obsolete, -dontroute is not supported by the compatibility proc" } {-outofband} { error "server_send if obsolete, -outofband is not supported by the compatibility proc" } } lappend cmd $opt } uplevel [concat $cmd $args] flush [lindex $args 0] } proc server_info args { eval [concat host_info $args] } proc server_cntl args { eval [concat fcntl $args] } #@package: TclX-ClockCompat fmtclock convertclock getclock # Added TclX 7.5a proc fmtclock {clockval {format {}} {zone {}}} { lappend cmd clock format $clockval if ![lempty $format] { lappend cmd -format $format } if ![lempty $zone] { lappend cmd -gmt 1 } return [eval $cmd] } # Added TclX 7.5a proc convertclock {dateString {zone {}} {baseClock {}}} { lappend cmd clock scan $dateString if ![lempty $zone] { lappend cmd -gmt 1 } if ![lempty $baseClock] { lappend cmd -base $baseClock } return [eval $cmd] } # Added TclX 7.5a proc getclock {} { return [clock seconds] } #@package: TclX-FileCompat mkdir rmdir unlink frename # Added TclX 7.6.0 proc mkdir args { set path 0 if {[llength $args] > 1} { lvarpop args set path 1 } foreach dir [lindex $args 0] { if {((!$path) && [file isdirectory $dir]) || \ ([file exists $dir] && ![file isdirectory $dir])} { error "creating directory \"$dir\" failed: file already exists" \ {} {POSIX EEXIST {file already exists}} } file mkdir $dir } return } # Added TclX 7.6.0 proc rmdir args { set nocomplain 0 if {[llength $args] > 1} { lvarpop args set nocomplain 1 global errorInfo errorCode set saveErrorInfo $errorInfo set saveErrorCode $errorCode } foreach dir [lindex $args 0] { if $nocomplain { catch {file delete $dir} } else { if ![file exists $dir] { error "can't remove \"$dir\": no such file or directory" {} \ {POSIX ENOENT {no such file or directory}} } if ![cequal [file type $dir] directory] { error "$dir: not a directory" {} \ {POSIX ENOTDIR {not a directory}} } file delete $dir } } if $nocomplain { set errorInfo $saveErrorInfo set errorCode $saveErrorCode } return } # Added TclX 7.6.0 proc unlink args { set nocomplain 0 if {[llength $args] > 1} { lvarpop args set nocomplain 1 global errorInfo errorCode set saveErrorInfo $errorInfo set saveErrorCode $errorCode } foreach file [lindex $args 0] { if {[file exists $file] && [cequal [file type $file] directory]} { if !$nocomplain { error "$file: not owner" {} {POSIX EPERM {not owner}} } } elseif $nocomplain { catch {file delete $file} } else { if {!([file exists $file] || \ ([catch {file readlink $file}] == 0))} { error "can't remove \"$file\": no such file or directory" {} \ {POSIX ENOENT {no such file or directory}} } file delete $file } } if $nocomplain { set errorInfo $saveErrorInfo set errorCode $saveErrorCode } return } # Added TclX 7.6.0 proc frename {old new} { if {[file isdirectory $new] && ![lempty [readdir $new]]} { error "rename \"foo\" to \"baz\" failed: directory not empty" {} \ POSIX ENOTEMPTY {directory not empty} } file rename -force $old $new } #@package: TclX-CopyFileCompat copyfile # Added TclX 8.0.0 # copyfile ?-bytes num | \-maxbytes num? ?\-translate? fromFileId toFileId proc copyfile args { global errorInfo errorCode set copyMode NORMAL set translate 0 while {[string match -* [lindex $args 0]]} { set opt [lvarpop args] switch -exact -- $opt { -bytes { set copyMode BYTES if {[llength $args] == 0} { error "argument required for -bytes option" } set totalBytesToRead [lvarpop args] } -maxbytes { set copyMode MAX_BYTES if {[llength $args] == 0} { error "argument required for -maxbytes option" } set totalBytesToRead [lvarpop args] } -translate { set translate 1 } default { error "invalid argument \"$opt\", expected \"-bytes\",\ \"-maxbytes\", or \"-translate\"" } } } if {[llength $args] != 2} { error "wrong # args: copyfile ?-bytes num|-maxbytes num? ?-translate?\ fromFileId toFileId" } lassign $args fromFileId toFileId if !$translate { set fromOptions [list \ [fconfigure $fromFileId -translation] \ [fconfigure $fromFileId -eofchar]] set toOptions [list \ [fconfigure $toFileId -translation] \ [fconfigure $toFileId -eofchar]] fconfigure $fromFileId -translation binary fconfigure $fromFileId -eofchar {} fconfigure $toFileId -translation binary fconfigure $toFileId -eofchar {} } set cmd [list fcopy $fromFileId $toFileId] if ![cequal $copyMode NORMAL] { lappend cmd -size $totalBytesToRead } set stat [catch {eval $cmd} totalBytesRead] if $stat { set saveErrorResult $totalBytesRead set saveErrorInfo $errorInfo set saveErrorCode $errorCode } if !$translate { # Try to restore state, even if we have an error. if [catch { fconfigure $fromFileId -translation [lindex $fromOptions 0] fconfigure $fromFileId -eofchar [lindex $fromOptions 1] fconfigure $toFileId -translation [lindex $toOptions 0] fconfigure $toFileId -eofchar [lindex $toOptions 1] } errorResult] { # If fcopy did not get an error, we process this one if !$stat { set stat 1 set saveErrorResult $errorResult set saveErrorInfo $errorInfo set saveErrorCode $errorCode } } } if $stat { error $saveErrorResult $saveErrorInfo $saveErrorCode } if {[cequal $copyMode BYTES] && ($totalBytesToRead > 0) && \ ($totalBytesRead != $totalBytesToRead)} { error "premature EOF, $totalBytesToRead bytes expected,\ $totalBytesRead bytes actually read" } return $totalBytesRead } tclx8.4-8.4.1.orig/library/arrayprocs.tcl0000644000000000000000000000315312046313166015116 0ustar # # arrayprocs.tcl -- # # Extended Tcl array procedures. # #------------------------------------------------------------------------------ # Copyright 1992-1999 Karl Lehenbauer and Mark Diekhans. # # Permission to use, copy, modify, and distribute this software and its # documentation for any purpose and without fee is hereby granted, provided # that the above copyright notice appear in all copies. Karl Lehenbauer and # Mark Diekhans make no representations about the suitability of this # software for any purpose. It is provided "as is" without express or # implied warranty. #------------------------------------------------------------------------------ # $Id: arrayprocs.tcl,v 1.2 2002/04/02 03:00:14 hobbs Exp $ #------------------------------------------------------------------------------ # #@package: TclX-ArrayProcedures for_array_keys proc for_array_keys {varName arrayName codeFragment} { upvar $varName enumVar $arrayName enumArray if {![array exists enumArray]} { return -code error "\"$arrayName\" isn't an array" } set code 0 set result {} set searchId [array startsearch enumArray] while {[array anymore enumArray $searchId]} { set enumVar [array nextelement enumArray $searchId] set code [catch {uplevel 1 $codeFragment} result] if {$code != 0 && $code != 4} break } array donesearch enumArray $searchId if {$code == 0 || $code == 3 || $code == 4} { return $result } if {$code == 1} { global errorCode errorInfo return -code $code -errorcode $errorCode -errorinfo $errorInfo $result } return -code $code $result } tclx8.4-8.4.1.orig/library/stringfile.tcl0000644000000000000000000000260512046313166015100 0ustar # # string_file -- # # Functions to read and write strings from a file that has not been opened. #------------------------------------------------------------------------------ # Copyright 1992-1999 Karl Lehenbauer and Mark Diekhans. # # Permission to use, copy, modify, and distribute this software and its # documentation for any purpose and without fee is hereby granted, provided # that the above copyright notice appear in all copies. Karl Lehenbauer and # Mark Diekhans make no representations about the suitability of this # software for any purpose. It is provided "as is" without express or # implied warranty. #------------------------------------------------------------------------------ # $Id: stringfile.tcl,v 1.1 2001/10/24 23:31:48 hobbs Exp $ #------------------------------------------------------------------------------ # #@package: TclX-stringfile_functions read_file write_file proc read_file {fileName args} { if {$fileName == "-nonewline"} { set flag $fileName set fileName [lvarpop args] } else { set flag {} } set fp [open $fileName] try_eval { set result [eval read $flag $fp $args] } {} { close $fp } return $result } proc write_file {fileName args} { set fp [open $fileName w] try_eval { foreach string $args { puts $fp $string } } {} { close $fp } } tclx8.4-8.4.1.orig/library/events.tcl0000644000000000000000000000203612046313166014234 0ustar # # eventloop.tcl -- # # Eventloop procedure. #------------------------------------------------------------------------------ # Copyright 1992-1999 Karl Lehenbauer and Mark Diekhans. # # Permission to use, copy, modify, and distribute this software and its # documentation for any purpose and without fee is hereby granted, provided # that the above copyright notice appear in all copies. Karl Lehenbauer and # Mark Diekhans make no representations about the suitability of this # software for any purpose. It is provided "as is" without express or # implied warranty. #------------------------------------------------------------------------------ # $Id: events.tcl,v 1.1 2001/10/24 23:31:48 hobbs Exp $ #------------------------------------------------------------------------------ # #@package: TclX-events mainloop proc mainloop {} { global tcl_interactive if {[info exists tcl_interactive] && $tcl_interactive} { commandloop -async -interactive on -endcommand exit } set loopVar 0 catch {vwait loopVar} exit } tclx8.4-8.4.1.orig/library/pushd.tcl0000644000000000000000000000351512046313166014056 0ustar # # pushd.tcl -- # # C-shell style directory stack procs. # #------------------------------------------------------------------------------ # Copyright 1992-1999 Karl Lehenbauer and Mark Diekhans. # # Permission to use, copy, modify, and distribute this software and its # documentation for any purpose and without fee is hereby granted, provided # that the above copyright notice appear in all copies. Karl Lehenbauer and # Mark Diekhans make no representations about the suitability of this # software for any purpose. It is provided "as is" without express or # implied warranty. #------------------------------------------------------------------------------ # $Id: pushd.tcl,v 1.2 2005/11/25 18:18:55 hobbs Exp $ #------------------------------------------------------------------------------ # #@package: TclX-directory_stack pushd popd dirs global TCLXENV(dirPushList) set TCLXENV(dirPushList) "" proc pushd {{new ""}} { global TCLXENV set current [pwd] if {[string length $new]} { set dirs [glob -nocomplain $new] set count [llength $dirs] if {$count == 0} { error "no such directory: $new" } elseif {$count != 1} { error "ambiguous directory: $new: [join $dirs {, }]" } cd [lindex $dirs 0] lvarpush TCLXENV(dirPushList) $current } else { if [lempty $TCLXENV(dirPushList)] { error "directory stack empty" } cd [lindex $TCLXENV(dirPushList) 0] lvarpop TCLXENV(dirPushList) lvarpush TCLXENV(dirPushList) $current } return [pwd] } proc popd {} { global TCLXENV if {[lempty $TCLXENV(dirPushList)]} { error "directory stack empty" } cd [lvarpop TCLXENV(dirPushList)] return [pwd] } proc dirs {} { global TCLXENV return [linsert $TCLXENV(dirPushList) 0 [pwd]] } tclx8.4-8.4.1.orig/library/showproc.tcl0000644000000000000000000000272412046313166014600 0ustar # # showproc.tcl -- # # Display procedure headers and bodies. #------------------------------------------------------------------------------ # Copyright 1992-1999 Karl Lehenbauer and Mark Diekhans. # # Permission to use, copy, modify, and distribute this software and its # documentation for any purpose and without fee is hereby granted, provided # that the above copyright notice appear in all copies. Karl Lehenbauer and # Mark Diekhans make no representations about the suitability of this # software for any purpose. It is provided "as is" without express or # implied warranty. #------------------------------------------------------------------------------ # $Id: showproc.tcl,v 1.1 2001/10/24 23:31:48 hobbs Exp $ #------------------------------------------------------------------------------ # #@package: TclX-showproc showproc proc showproc args { if [lempty $args] { set args [info procs] } set out {} foreach procname $args { if [lempty [info procs $procname]] { auto_load $procname } set arglist [info args $procname] set nargs {} while {[llength $arglist] > 0} { set varg [lvarpop arglist 0] if [info default $procname $varg defarg] { lappend nargs [list $varg $defarg] } else { lappend nargs $varg } } append out "proc $procname [list $nargs] \{[info body $procname]\}\n" } return $out } tclx8.4-8.4.1.orig/library/fmath.tcl0000644000000000000000000000427612046313166014037 0ustar # # fmath.tcl -- # # Contains a package of procs that interface to the Tcl expr command built-in # functions. These procs provide compatibility with older versions of TclX and # are also generally useful. #------------------------------------------------------------------------------ # Copyright 1993-1999 Karl Lehenbauer and Mark Diekhans. # # Permission to use, copy, modify, and distribute this software and its # documentation for any purpose and without fee is hereby granted, provided # that the above copyright notice appear in all copies. Karl Lehenbauer and # Mark Diekhans make no representations about the suitability of this # software for any purpose. It is provided "as is" without express or # implied warranty. #------------------------------------------------------------------------------ # $Id: fmath.tcl,v 1.2 2002/04/02 03:00:14 hobbs Exp $ #------------------------------------------------------------------------------ #@package: TclX-fmath acos asin atan ceil cos cosh exp fabs floor log log10 \ sin sinh sqrt tan tanh fmod pow atan2 abs double int round proc acos x {uplevel 1 [list expr acos($x)]} proc asin x {uplevel 1 [list expr asin($x)]} proc atan x {uplevel 1 [list expr atan($x)]} proc ceil x {uplevel 1 [list expr ceil($x)]} proc cos x {uplevel 1 [list expr cos($x)]} proc cosh x {uplevel 1 [list expr cosh($x)]} proc exp x {uplevel 1 [list expr exp($x)]} proc fabs x {uplevel 1 [list expr abs($x)]} proc floor x {uplevel 1 [list expr floor($x)]} proc log x {uplevel 1 [list expr log($x)]} proc log10 x {uplevel 1 [list expr log10($x)]} proc sin x {uplevel 1 [list expr sin($x)]} proc sinh x {uplevel 1 [list expr sinh($x)]} proc sqrt x {uplevel 1 [list expr sqrt($x)]} proc tan x {uplevel 1 [list expr tan($x)]} proc tanh x {uplevel 1 [list expr tanh($x)]} proc fmod {x n} {uplevel 1 [list expr fmod($x,$n)]} proc pow {x n} {uplevel 1 [list expr pow($x,$n)]} # New functions that TclX did not provide in eariler versions. proc atan2 x {uplevel 1 [list expr atan2($x)]} proc abs x {uplevel 1 [list expr abs($x)]} proc double x {uplevel 1 [list expr double($x)]} proc int x {uplevel 1 [list expr int($x)]} proc round x {uplevel 1 [list expr round($x)]} tclx8.4-8.4.1.orig/library/profrep.tcl0000644000000000000000000001215212046313166014405 0ustar # # profrep -- # # Generate Tcl profiling reports. #------------------------------------------------------------------------------ # Copyright 1992-1999 Karl Lehenbauer and Mark Diekhans. # # Permission to use, copy, modify, and distribute this software and its # documentation for any purpose and without fee is hereby granted, provided # that the above copyright notice appear in all copies. Karl Lehenbauer and # Mark Diekhans make no representations about the suitability of this # software for any purpose. It is provided "as is" without express or # implied warranty. #------------------------------------------------------------------------------ # $Id: profrep.tcl,v 1.1 2001/10/24 23:31:48 hobbs Exp $ #------------------------------------------------------------------------------ # #@package: TclX-profrep profrep namespace eval TclXProfRep { # # Convert the profile array from entries that have only the time spent in # the proc to the time spend in the proc and all it calls. # proc sum {inDataVar outDataVar} { upvar 1 $inDataVar inData $outDataVar outData foreach inStack [array names inData] { for {set idx 0} {![lempty [set part [lrange $inStack $idx end]]]} \ {incr idx} { if ![info exists outData($part)] { set outData($part) {0 0 0} } lassign $outData($part) count real cpu if {$idx == 0} { incr count [lindex $inData($inStack) 0] } incr real [lindex $inData($inStack) 1] incr cpu [lindex $inData($inStack) 2] set outData($part) [list $count $real $cpu] } } } # # Do sort comparison. May only be called by sort, as it address its # local variables. # proc sortcmp {key1 key2} { upvar profData profData keyIndex keyIndex set val1 [lindex $profData($key1) $keyIndex] set val2 [lindex $profData($key2) $keyIndex] if {$val1 < $val2} { return -1 } if {$val1 > $val2} { return 1 } return 0 } # # Generate a list, sorted in descending order by the specified key, contain # the indices into the summarized data. # proc sort {profDataVar sortKey} { upvar $profDataVar profData case $sortKey { {calls} {set keyIndex 0} {real} {set keyIndex 1} {cpu} {set keyIndex 2} default { error "Expected a sort type of: `calls', `cpu' or ` real'" } } return [lsort -integer -decreasing -command sortcmp \ [array names profData]] } # # Print the sorted report # proc print {profDataVar sortedProcList outFile userTitle} { upvar $profDataVar profData set maxNameLen 0 foreach procStack [array names profData] { foreach procName $procStack { set maxNameLen [max $maxNameLen [clength $procName]] } } if {$outFile == ""} { set outFH stdout } else { set outFH [open $outFile w] } # Output a header. set stackTitle "Procedure Call Stack" set maxNameLen [max [expr $maxNameLen+6] [expr [clength $stackTitle]+4]] set hdr [format "%-${maxNameLen}s %10s %10s %10s" $stackTitle \ "Calls" "Real Time" "CPU Time"] if {$userTitle != ""} { puts $outFH [replicate - [clength $hdr]] puts $outFH $userTitle } puts $outFH [replicate - [clength $hdr]] puts $outFH $hdr puts $outFH [replicate - [clength $hdr]] # Output the data in sorted order. Trim leading ::. foreach procStack $sortedProcList { set data $profData($procStack) set cmd [lvarpop procStack] regsub {^::} $cmd {} cmd puts $outFH [format "%-${maxNameLen}s %10d %10d %10d" \ $cmd [lindex $data 0] [lindex $data 1] \ [lindex $data 2]] foreach procName $procStack { if {$procName == ""} break regsub {^::} $procName {} procName puts $outFH " $procName" } } if {$outFile != ""} { close $outFH } } } ;# TclXProfRep #------------------------------------------------------------------------------ # Generate a report from data collect from the profile command. # o profDataVar (I) - The name of the array containing the data from profile. # o sortKey (I) - Value to sort by. One of "calls", "cpu" or "real". # o outFile (I) - Name of file to write the report to. If omitted, stdout # is assumed. # o userTitle (I) - Title line to add to output. proc profrep {profDataVar sortKey {outFile {}} {userTitle {}}} { upvar $profDataVar profData TclXProfRep::sum profData sumProfData set sortedProcList [TclXProfRep::sort sumProfData $sortKey] TclXProfRep::print sumProfData $sortedProcList $outFile $userTitle } tclx8.4-8.4.1.orig/library/convlib.tcl0000644000000000000000000000756112046313166014374 0ustar # # convlib.tcl -- # # Convert Ousterhout style tclIndex files and associated libraries to a # package library. # #------------------------------------------------------------------------------ # Copyright 1992-1999 Karl Lehenbauer and Mark Diekhans. # # Permission to use, copy, modify, and distribute this software and its # documentation for any purpose and without fee is hereby granted, provided # that the above copyright notice appear in all copies. Karl Lehenbauer and # Mark Diekhans make no representations about the suitability of this # software for any purpose. It is provided "as is" without express or # implied warranty. #------------------------------------------------------------------------------ # $Id: convlib.tcl,v 1.1 2001/10/24 23:31:48 hobbs Exp $ #------------------------------------------------------------------------------ # #@package: TclX-convertlib convert_lib namespace eval TclX { #-------------------------------------------------------------------------- # ParseTclIndex # Parse a tclIndex file, returning an array of file names with the list of # procedures in each package. This is done by sourcing the file and then # going through the local auto_index array that was created. Issues # warnings for lines that can't be converted. # # Returns 1 if all lines are converted, 0 if some failed. # proc ParseTclIndex {tclIndex fileTblVar ignore} { upvar $fileTblVar fileTbl set allOK 1 # Open and validate the file. set tclIndexFH [open $tclIndex r] try_eval { set hdr [gets $tclIndexFH] if {!([cequal $hdr {# Tcl autoload index file, version 2.0}] || [cequal $hdr == {# Tcl autoload index file, version 2.0 for [incr Tcl]}])} { error "can only convert version 2.0 Tcl auto-load files" } set dir [file dirname $tclIndex] ;# Expected by the script. eval [read $tclIndexFH] } {} { close $tclIndexFH } foreach procName [array names auto_index] { if ![string match "source *" $auto_index($procName)] { puts stderr "WARNING: Can't convert load command for\ \"$procName\": $auto_index($procName)" set allOK 0 continue } set filePath [lindex $auto_index($procName) 1] set fileName [file tail $filePath] if {[lsearch $ignore $fileName] >= 0} continue lappend fileTbl($filePath) $procName } if ![info exists fileTbl] { error "no entries could be converted in $tclIndex" } return $allOK } } ;# namespace TclX #-------------------------------------------------------------------------- # convert_lib: # Convert a tclIndex library to a .tlib. ignore any files in the ignore # list proc convert_lib {tclIndex packageLib {ignore {}}} { if {[file tail $tclIndex] != "tclIndex"} { error "Tail file name must be `tclIndex': $tclIndex"} if ![file readable $tclIndex] { error "File not readable: $tclIndex" } # Parse the file. set allOK [TclX::ParseTclIndex $tclIndex fileTbl $ignore] # Generate the .tlib package names with contain the directory and # file name, less any extensions. if {[file extension $packageLib] != ".tlib"} { append packageLib ".tlib" } set libFH [open $packageLib w] foreach srcFile [array names fileTbl] { set pkgName [file tail [file dirname $srcFile]]/[file tail [file root $srcFile]] set srcFH [open $srcFile r] puts $libFH "#@package: $pkgName $fileTbl($srcFile)\n" copyfile $srcFH $libFH close $srcFH } close $libFH buildpackageindex $packageLib if !$allOK { error "*** Not all entries converted, but library generated" } } tclx8.4-8.4.1.orig/tests/0000755000000000000000000000000012046525461011724 5ustar tclx8.4-8.4.1.orig/tests/msgcat.test0000644000000000000000000000760712046313167014113 0ustar # # msgcat.test # # Tests for the XPG/3 message catalog commands. #--------------------------------------------------------------------------- # Copyright 1992-1999 Karl Lehenbauer and Mark Diekhans. # # Permission to use, copy, modify, and distribute this software and its # documentation for any purpose and without fee is hereby granted, provided # that the above copyright notice appear in all copies. Karl Lehenbauer and # Mark Diekhans make no representations about the suitability of this # software for any purpose. It is provided "as is" without express or # implied warranty. #------------------------------------------------------------------------------ # $Id: msgcat.test,v 1.3 2002/04/04 06:10:30 hobbs Exp $ #------------------------------------------------------------------------------ if {[cequal [info procs Test] {}]} { source [file join [file dirname [info script]] testlib.tcl] } # # This only tests default strings, since its difficult to setup and rely on # a message catalog being present. This will work on systems without message # catalogs, as the stubs return default strings. # test message-cat-1.1 {catopen tests} { set msgcat [catopen "FOOBAZWAP"] catclose $msgcat crange $msgcat 0 5 } {msgcat} test message-cat-1.2 {catopen tests} { set msgcat [catopen -nofail "FOOBAZWAP"] catclose $msgcat crange $msgcat 0 5 } {msgcat} test message-cat-1.3 {catopen tests} { list [catch {catopen -fail "FOOBAZWAP"} msg] $msg switch -exact $msg { "open of message catalog failed" - "the message catalog facility is not available, default string is always returned" {concat "OK"} default { # This will fail on Linux and FreeBSD, where the catopen libc # function exhibits non-standard behavior. This is should not be # a problem for most developers, so fake the OK. if {[regexp Linux|FreeBSD $::tcl_platform(os)] && \ ($msg == "msgcat0")} { concat "OK" } else { concat "Bad catopen return: $msg" } } } } {OK} test message-cat-2.1 {catclose tests} { set msgcat [catopen "FOOBAZWAP"] catclose $msgcat list [catch {catgets $msgcat} msg] $msg } {1 {wrong # args: catgets catHandle setnum msgnum defaultstr}} test message-cat-2.2 {catclose tests} { set msgcat [catopen "FOOBAZWAP"] catclose $msgcat } {} test message-cat-2.3 {catclose tests} { set msgcat [catopen "FOOBAZWAP"] catclose -nofail $msgcat } {} test message-cat-2.4 {catclose tests} { set msgcat [catopen "FOOBAZWAP"] catclose $msgcat list [catch {catclose -fail $msgcat} msg] $msg } {1 {msgcat is not open}} test message-cat-2.5 {catclose tests} { list [catch {catclose baz} msg] $msg } {1 {invalid msgcat handle "baz"}} test message-cat-2.6 {catclose tests} { list [catch {catclose} msg] $msg } {1 {wrong # args: catclose ?-fail|-nofail? catHandle}} test message-cat-3.1 {catgets tests} { set msgcat [catopen "FOOBAZWAP"] catgets $msgcat 1 12 "This is a test" } {This is a test} catch {catclose $msgcat} test message-cat-3.2 {catgets tests} { set msgcat [catopen "FOOBAZWAP"] catgets $msgcat 101 12 "This is an actual emergency" } {This is an actual emergency} catch {catclose $msgcat} test message-cat-3.3 {catgets tests} { set msgcat [catopen "FOOBAZWAP"] catclose $msgcat list [catch {catgets $msgcat 101 12 "This is an actual emergency"} msg] \ $msg } {1 {msgcat is not open}} test message-cat-3.4 {catgets tests} { set msgcat [catopen "FOOBAZWAP"] list [catch {catgets $msgcat xx 12 "This is an actual emergency"} msg] $msg } {1 {expected integer but got "xx"}} catch {catclose $msgcat} test message-cat-3.5 {catgets tests} { set msgcat [catopen "FOOBAZWAP"] list [catch {catgets $msgcat 102 "This is an actual emergency"} msg] $msg } {1 {wrong # args: catgets catHandle setnum msgnum defaultstr}} catch {catclose $msgcat} # cleanup ::tcltest::cleanupTests return tclx8.4-8.4.1.orig/tests/select.test0000644000000000000000000001017012046313166014100 0ustar # # select.test # # Tests for the select command. #--------------------------------------------------------------------------- # Copyright 1992-1999 Karl Lehenbauer and Mark Diekhans. # # Permission to use, copy, modify, and distribute this software and its # documentation for any purpose and without fee is hereby granted, provided # that the above copyright notice appear in all copies. Karl Lehenbauer and # Mark Diekhans make no representations about the suitability of this # software for any purpose. It is provided "as is" without express or # implied warranty. #------------------------------------------------------------------------------ # $Id: select.test,v 1.2 2002/04/02 02:29:43 hobbs Exp $ #------------------------------------------------------------------------------ # if {[cequal [info procs Test] {}]} { source [file join [file dirname [info script]] testlib.tcl] } if [cequal $tcl_platform(platform) windows] { echo " * The select tests have not been ported to Win32" return } catch {select} msg # FIX: Should have an infox check. if {"$msg" == "select is not available on this version of Unix"} { echo "**** $msg" echo "**** tests skipped" return } # # Note: The behavior of what is returned for write-ready is not consistent, # some systems (BSD 4.4) don't return a pipe file handle that has been # written to but not read from. This is the reason for the lsearch checks # below. # pipe pipe1ReadFh pipe1WriteFh fcntl $pipe1WriteFh nobuf 1 pipe pipe2ReadFh pipe2WriteFh fcntl $pipe2WriteFh nobuf 1 set pipeReadList [list $pipe1ReadFh $pipe2ReadFh] set pipeWriteList [list $pipe1WriteFh $pipe2WriteFh] Test select-1.1 {select tests} { select $pipeReadList $pipeWriteList {} 0.5 } 0 [list {} $pipeWriteList {}] Test select-1.2 {select tests} { puts $pipe1WriteFh "Written to pipe 1" set ret [select $pipeReadList $pipeWriteList {} 0.5] list [lindex $ret 0] \ [expr [lsearch [lindex $ret 1] $pipe2WriteFh] >= 0] \ [lindex $ret 2] \ [gets $pipe1ReadFh] } 0 [list $pipe1ReadFh 1 {} "Written to pipe 1"] Test select-1.3 {select tests} { puts $pipe2WriteFh "Written to pipe 2" set ret [select $pipeReadList $pipeWriteList {} 0.5] list [lindex $ret 0] \ [expr [lsearch [lindex $ret 1] $pipe1WriteFh] >= 0] \ [lindex $ret 2] \ [gets $pipe2ReadFh] } 0 [list $pipe2ReadFh 1 {} "Written to pipe 2"] Test select-1.4 {select tests} { puts $pipe1WriteFh "Written to pipe 1" puts $pipe2WriteFh "Written to pipe 2" set ret [select $pipeReadList {} {} 0.5] list $ret [gets $pipe1ReadFh] [gets $pipe2ReadFh] } 0 [list [list $pipeReadList {} {}] "Written to pipe 1" \ "Written to pipe 2"] Test select-1.5 {select tests} { select $pipeReadList $pipeWriteList {} 0 } 0 [list {} $pipeWriteList {}] Test select-1.6 {select tests} { puts $pipe1WriteFh "Written to pipe 1" set ret [select $pipeReadList $pipeWriteList] list [lindex $ret 0] \ [expr [lsearch [lindex $ret 1] $pipe2WriteFh] >= 0] \ [lindex $ret 2] \ [gets $pipe1ReadFh] } 0 [list $pipe1ReadFh 1 {} "Written to pipe 1"] Test select-1.7 {select tests} { puts $pipe1WriteFh "Written to pipe 1" set ret [select $pipeReadList $pipeWriteList {} 0] list [lindex $ret 0] \ [expr [lsearch [lindex $ret 1] $pipe2WriteFh] >= 0] \ [lindex $ret 2] \ [gets $pipe1ReadFh] } 0 [list $pipe1ReadFh 1 {} "Written to pipe 1"] Test select-1.8 {select tests} { puts $pipe1WriteFh "Written to pipe 1 #1" puts $pipe1WriteFh "Written to pipe 1 #2" set ret1 [select $pipeReadList {} {} 0] set data1 [gets $pipe1ReadFh] set ret2 [select $pipeReadList {} {} 0] set data2 [gets $pipe1ReadFh] list $ret1 $data1 $ret2 $data2 } 0 [list [list $pipe1ReadFh {} {}] "Written to pipe 1 #1" \ [list $pipe1ReadFh {} {}] "Written to pipe 1 #2"] Test select-2.1 {select tests} { select foo $pipeWriteList {} 0 } 1 {can not find channel named "foo"} Test select-2.2 {select tests} { select $pipeReadList $pipeWriteList {} X } 1 {expected floating-point number but got "X"} # cleanup ::tcltest::cleanupTests return tclx8.4-8.4.1.orig/tests/help.test0000644000000000000000000001505212046313166013555 0ustar # # help.test # # Tests for the help subsystem. Help must be build first. If help files # change, thest tests may have to be changed. #--------------------------------------------------------------------------- # Copyright 1992-1999 Karl Lehenbauer and Mark Diekhans. # # Permission to use, copy, modify, and distribute this software and its # documentation for any purpose and without fee is hereby granted, provided # that the above copyright notice appear in all copies. Karl Lehenbauer and # Mark Diekhans make no representations about the suitability of this # software for any purpose. It is provided "as is" without express or # implied warranty. #------------------------------------------------------------------------------ # $Id: help.test,v 1.4 2005/03/25 19:59:44 hobbs Exp $ #------------------------------------------------------------------------------ # if {[cequal [info procs Test] {}]} { source [file join [file dirname [info script]] testlib.tcl] } if [cequal $tcl_platform(platform) windows] { echo " * The help tests have not been ported to Win32" return } TestRemove HELP.PRG # # Only run help test if help has been built. # if {[info exists ::env(TCLX_HELP_DIR)] && [file exists $::env(TCLX_HELP_DIR)]} { set HELPDIR $::env(TCLX_HELP_DIR) } else { set HELPDIR [file join $tclx_library help] } if [cequal [glob -nocomplain [file join $HELPDIR *]] ""] { puts "*************************************************************" puts "No help pages in: " puts " $HELPDIR" puts "Help tests will be skipped." puts "*************************************************************" return } #------------------------------------------------------------------------------ # Read a line from the server, set an alarm to make sure it doesn't hang. # Handle pager `:' prompts specially. proc ReadServer {} { global helpServerFH alarm 45 if {[gets $helpServerFH line] < 0} { alarm 0 error "EOF from help server" } alarm 0 return $line } #------------------------------------------------------------------------------ # Eat a prompt line from the help server. proc EatServerPrompt {} { set line [ReadServer] if ![cequal $line "===HELPSERVER==="] { error "unexpected output from help server: `$line'" } } #------------------------------------------------------------------------------ # Send a command to the help server and return the output. The help server # output will be bracketed with commands to mark the beginning and ending. # An extra newline is always queued to continue the help pager. The prompt of # the pager will be removed from the output. This assumes that the output has # no lines starting with `:'. # proc HelpSend {cmd pagerCntVar} { global helpServerFH upvar $pagerCntVar pagerCnt puts $helpServerFH $cmd puts $helpServerFH "" ;# Just a new line.. set pagerCnt 0 set results {} # Read lines of the output. while 1 { set line [ReadServer] if [cequal [cindex $line 0] ":"] { set line [crange $line 1 end] incr pagerCnt puts $helpServerFH "" ;# Just a new line } if [cequal "$line" "===HELPSERVER==="] { break } append results $line "\n" } # Eat the extra prompt caused by the typed-ahead newline EatServerPrompt return $results } # # Create the help server process, which will execute the commands, # with stdin and stdout redirected to pipes. # global helpServerFH set fh [open HELP.PRG w] puts $fh { package require Tclx namespace import -force tclx::help* tclx::apropos fconfigure stdout -buffering none fconfigure stderr -buffering none commandloop -interactive on -prompt1 {subst "===HELPSERVER===\n"} \ -prompt2 {error "Help server incomplete cmd"} error "Help server got eof" } close $fh set helpServerFH [open "|[list $::tcltest::tcltest HELP.PRG]" r+] fconfigure $helpServerFH -buffering none # # An alarm will be set when talking to the server uncase it doesn't talk back # signal error SIGALRM # Nuke the first prompt EatServerPrompt # Now run the tests. Test help-1.1 {help tests} { HelpSend "help" promptCnt } 0 { Subjects available in /: tcl/ Help pages available in /: help } Test help-1.1.1 {help tests} { HelpSend "help tcl" promptCnt } 0 { Subjects available in /tcl: control/ debug/ events/ files/ filescan/ intl/ intro/ keyedlists/ libraries/ lists/ math/ processes/ signals/ sockets/ status/ strings/ tclshell/ time/ variables/ } Test help-1.2 {help tests} { HelpSend "helppwd" promptCnt } 0 {Current help subject: / } Test help-1.3 {help tests} { HelpSend "helpcd tcl/filescan" promptCnt } 0 {} Test help-1.4 {help tests} { HelpSend "helppwd" promptCnt } 0 {Current help subject: /tcl/filescan } Test help-1.5 {help tests} { set result [HelpSend "help /tcl/lists/lassign" promptCnt] set fh [open "$HELPDIR/tcl/lists/lassign"] set expect [read $fh] close $fh set summary {} if {"$expect" == "$result"} { append summary "CORRECT" } else { append summary "DATA DOES NOT MATCH : $result" } if {$promptCnt == 0} { append summary " : PROMPT OK" } else { append summary " : TOO MANY PROMPTS: $promptCnt" } set summary } 0 {CORRECT : PROMPT OK} Test help-1.6 {help tests} { set result [HelpSend "help /tcl/math/expr" promptCnt] set fh [open "$HELPDIR/tcl/math/expr"] set expect [read $fh] close $fh set summary {} if {"$expect" == "$result"} { append summary "CORRECT" } else { append summary "DATA DOES NOT MATCH: $result" } if {$promptCnt >= 2} { append summary " : PROMPT OK" } else { append summary " : NOT ENOUGH PROMPTS: $promptCnt" } set summary } 0 {CORRECT : PROMPT OK} Test help-1.7 {help tests} { HelpSend "apropos upvar" promptCnt } 0 {tcl/variables/upvar - Create link to variable in a different stack frame } Test help-1.8 {help tests} { HelpSend "apropos clock" promptCnt } 0 {tcl/time/clock - Obtain and manipulate time tcl/time/alarm - Set a process alarm clock. } Test help-1.9 {help tests} { HelpSend "helpcd" promptCnt } 0 {} Test help-1.10 {help tests} { HelpSend "helppwd" promptCnt } 0 {Current help subject: / } # Terminate the help server. puts $helpServerFH "exit 0" close $helpServerFH TestRemove HELP.PRG # cleanup ::tcltest::cleanupTests return tclx8.4-8.4.1.orig/tests/chroot.test0000644000000000000000000000511712046313166014124 0ustar # # chroot.test # # Tests for the chroot command. #--------------------------------------------------------------------------- # Copyright 1993-1999 Karl Lehenbauer and Mark Diekhans. # # Permission to use, copy, modify, and distribute this software and its # documentation for any purpose and without fee is hereby granted, provided # that the above copyright notice appear in all copies. Karl Lehenbauer and # Mark Diekhans make no representations about the suitability of this # software for any purpose. It is provided "as is" without express or # implied warranty. #------------------------------------------------------------------------------ # $Id: #------------------------------------------------------------------------------ # if {[cequal [info procs Test] {}]} { source [file join [file dirname [info script]] testlib.tcl] } # # Fork without exec will not work under Tk, skip this test # if {[info exists tk_version]} { puts "*************************************************************" puts "Chroot tests are constructed in a way that does not work" puts "under Tk. Test skipped." puts "*************************************************************" return } test chroot-1.1 {chroot tests} {unixOnly} { list [catch {chroot} msg] $msg } {1 {wrong # args: chroot path}} test chroot-1.2 {chroot tests} {unixOnly} { list [catch {chroot a b} msg] $msg } {1 {wrong # args: chroot path}} test chroot-1.3 {chroot tests} {pcOnly} { list [catch {chroot a} msg] $msg } {1 {chroot is not available on MS Windows}} # # Actually doing something real with chroot only makes sense on unix. # if ![cequal $tcl_platform(platform) "unix"] { # cleanup ::tcltest::cleanupTests return } if {[id user] != "root"} { puts "*******************************************************************" puts "You are not running as `root', certain chroot tests will be skipped" puts "*******************************************************************" # cleanup ::tcltest::cleanupTests return } # # clean up and create an empty test directory # set CHROOTDIR __CHROOTDIR.TEST catch {file delete -force $CHROOTDIR} file mkdir $CHROOTDIR # # since you can't chroot back up, we spawn a child process to do the # actual chroot # set pid [fork] # # parent waits for child to complete # if {$pid > 0} { wait $pid file delete -force $CHROOTDIR # cleanup ::tcltest::cleanupTests return } # # child tests chroot then exits # test chroot-2.1 {chroot tests} {isRoot} { chroot $CHROOTDIR glob -nocomplain /* } {} # cleanup ::tcltest::cleanupTests exit tclx8.4-8.4.1.orig/tests/keylist.test0000644000000000000000000003605112046313167014314 0ustar # # keylist.test # # Tests for the keylget, keylkeys, keylset, and keyldel commands. #--------------------------------------------------------------------------- # Copyright 1992-1999 Karl Lehenbauer and Mark Diekhans. # # Permission to use, copy, modify, and distribute this software and its # documentation for any purpose and without fee is hereby granted, provided # that the above copyright notice appear in all copies. Karl Lehenbauer and # Mark Diekhans make no representations about the suitability of this # software for any purpose. It is provided "as is" without express or # implied warranty. #------------------------------------------------------------------------------ # $Id: keylist.test,v 1.4 2005/11/18 00:01:50 hobbs Exp $ #------------------------------------------------------------------------------ # if {[cequal [info procs Test] {}]} { source [file join [file dirname [info script]] testlib.tcl] } # # Some pre-build keyed lists to test with. # set list1 {{keyA valueA} {keyB valueB} {keyD valueD}} set list2 {{keyA valueA} {keyB {{keyB1 valueB1} {keyB2 valueB2}}} {keyD valueD}} set list3 {{C {{CC {{CCC ccc}}}}} {A {{AA aa} {AB ab}}} {B {{BA ba} {BB bb} {BC {{BBB bbb}}}}}} set list4 [list [list keyA "value\0A"] [list keyB value\0\1\0B] \ [list keyD \0value\0D]] Test keylist-1.1 {keylget tests} { keylget list1 keyA } 0 {valueA} Test keylist-1.2 {keylget tests} { list [keylget list1 keyA value] $value } 0 {1 valueA} Test keylist-1.3 {keylget tests} { keylget list2 keyD } 0 {valueD} Test keylist-1.4 {keylget tests} { list [keylget list2 keyD value] $value } 0 {1 valueD} Test keylist-1.6 {keylget tests} { keylget list2 keyC value } 0 {0} Test keylist-1.7 {keylget tests} { keylget list2 keyB } 0 {{keyB1 valueB1} {keyB2 valueB2}} Test keylist-1.8 {keylget tests} { keylget list2 } 0 {keyA keyB keyD} Test keylist-1.9 {keylget tests} { set keyedlist {} keylget keyedlist keyC value } 0 {0} Test keylist-1.10 {keylget tests} { set keyedlist {} keylget keyedlist } 0 {} Test keylist-1.11 {keylget tests} { set keyedlist $list2 keylget keyedlist keyB.keyB1 } 0 {valueB1} Test keylist-1.12 {keylget tests} { set keyedlist $list2 keylget keyedlist keyB.keyB2 } 0 {valueB2} Test keylist-1.13 {keylget tests} { set keyedlist $list3 keylget keyedlist C } 0 {{CC {{CCC ccc}}}} Test keylist-1.14 {keylget tests} { set keyedlist $list3 keylget keyedlist C.CC } 0 {{CCC ccc}} Test keylist-1.15 {keylget tests} { set keyedlist $list3 keylget keyedlist C.CC.CCC } 0 {ccc} Test keylist-1.16 {keylget tests} { set keyedlist $list3 keylget keyedlist A.AB } 0 {ab} Test keylist-1.17 {keylget tests} { set keyedlist $list3 keylget keyedlist B.BC } 0 {{BBB bbb}} Test keylist-1.18 {keylget tests} { keylget list2 keyC } 1 {key "keyC" not found in keyed list} Test keylist-1.19 {keylget tests} { set keyedlist {{} {keyB valueB} {keyD valueD}} keylget keyedlist keyB } 1 {keyed list entry must be a valid, 2 element list, got ""} Test keylist-1.20 {keylget tests} { set keyedlist {keyA {keyB valueB} {keyD valueD}} keylget keyedlist keyB } 1 {keyed list entry must be a valid, 2 element list, got "keyA"} Test keylist-1.21 {keylget tests} { set keyedlist {{{} valueA} {keyB valueB} {keyD valueD}} keylget keyedlist keyB } 1 {keyed list key may not be an empty string} Test keylist-1.21 {keylget tests} { set keyedlist {{{} valueA} {keyB valueB} {keyD valueD}} keylget keyedlist keyB } 1 {keyed list key may not be an empty string} Test keylist-1.24 {keylget tests} { set keyedlist {{{key.A} valueA} {keyB valueB} {keyD valueD}} keylget keyedlist keyB } 1 {keyed list key may not contain a "."; it is used as a separator in key paths} Test keylist-1.25 {keylget tests} { keylget } 1 {wrong # args: keylget listvar ?key? ?retvar | {}?} Test keylist-1.26 {keylget tests} { unset keyedlist keylset keyedlist keyA aaa"bbb keylget keyedlist keyA } 0 {aaa"bbb} Test keylist-1.27 {keylget tests} { keylget list4 keyA } 0 "value\0A" Test keylist-1.28 {keylget tests} { keylget list4 keyB } 0 "value\0\1\0B" Test keylist-1.29 {keylget tests} { keylget list4 keyD } 0 "\0value\0D" Test keylist-2.1 {keylkeys tests} { keylkeys list1 } 0 {keyA keyB keyD} Test keylist-2.2 {keylkeys tests} { keylkeys list2 } 0 {keyA keyB keyD} Test keylist-2.3 {keylkeys tests} { keylkeys list2 keyB } 0 {keyB1 keyB2} Test keylist-2.4 {keylkeys tests} { set keyedlist $list3 keylkeys keyedlist } 0 {C A B} Test keylist-2.5 {keylkeys tests} { set keyedlist $list3 keylkeys keyedlist C } 0 {CC} Test keylist-2.6 {keylkeys tests} { set keyedlist $list3 keylkeys keyedlist C.CC } 0 {CCC} Test keylist-2.7 {keylkeys tests} { set keyedlist $list3 keylkeys keyedlist B.BC } 0 {BBB} Test keylist-2.8 {keylkeys tests} { keylkeys } 1 {wrong # args: keylkeys listvar ?key?} Test keylist-2.9 {keylkeys tests} { keylkeys list4 } 0 {keyA keyB keyD} Test keylist-3.1 {keylset tests} { catch {unset keyedlist} keylset keyedlist keyA valueA set keyedlist } 0 {{keyA valueA}} Test keylist-3.2 {keylset tests} { catch {unset keyedlist} keylset keyedlist keyA valueA keylset keyedlist keyB valueB set keyedlist } 0 {{keyA valueA} {keyB valueB}} Test keylist-3.3 {keylset tests} { catch {unset keyedlist} keylset keyedlist keyA valueA keylset keyedlist keyB valueB keyB valueB2 set keyedlist } 0 {{keyA valueA} {keyB valueB2}} Test keylist-3.3.1 {keylset tests} { catch {unset keyedlist} keylset keyedlist keyA value\0A keylset keyedlist keyB \0valueB keyB \0value\0\1\0B2 set keyedlist } 0 [list [list keyA value\0A] [list keyB \0value\0\1\0B2]] Test keylist-3.4 {keylset tests} { catch {unset keyedlist} keylset keyedlist keyA valueA keylset keyedlist keyB valueB keylset keyedlist keyA valueA2 keyB valueB2 keyC valueC set keyedlist } 0 {{keyA valueA2} {keyB valueB2} {keyC valueC}} Test keylist-3.5 {keylset tests} { catch {unset keyedlist} keylset keyedlist keyA } 1 {wrong # args: keylset listvar key value ?key value...?} Test keylist-3.6 {keylset tests} { catch {unset keyedlist} keylset keyedlist keyA valueA keyB } 1 {wrong # args: keylset listvar key value ?key value...?} Test keylist-3.7 {keylset tests} { catch {unset keyedlist} set keyedlist(foo) 1 keylset keyedlist keyA valueA } 1 {can't set "keyedlist": variable is array} Test keylist-3.8 {keylset tests} { catch {unset keyedlist} set keyedlist {{keyA valueA valueBad} {keyB valueB}} keylset keyedlist keyA valueA } 1 {keyed list entry must be a valid, 2 element list, got "keyA valueA valueBad"} Test keylist-3.8.1 {keylset tests} { catch {unset keyedlist} keylset keyedlist {} valueA } 1 {keyed list key may not be an empty string} Test keylist-3.9 {keylset tests} { set keyedlist {} keylset keyedlist C.CC.CCC ccc set keyedlist } 0 {{C {{CC {{CCC ccc}}}}}} Test keylist-3.10 {keylset tests} { keylset keyedlist A.AA aa set keyedlist } 0 {{C {{CC {{CCC ccc}}}}} {A {{AA aa}}}} Test keylist-3.11 {keylset tests} { keylset keyedlist A.AB ab set keyedlist } 0 {{C {{CC {{CCC ccc}}}}} {A {{AA aa} {AB ab}}}} Test keylist-3.12 {keylset tests} { keylset keyedlist B.BA ba set keyedlist } 0 {{C {{CC {{CCC ccc}}}}} {A {{AA aa} {AB ab}}} {B {{BA ba}}}} Test keylist-3.13 {keylset tests} { keylset keyedlist B.BB bb set keyedlist } 0 {{C {{CC {{CCC ccc}}}}} {A {{AA aa} {AB ab}}} {B {{BA ba} {BB bb}}}} Test keylist-3.14 {keylset tests} { keylset keyedlist B.BC.BBB bbb set keyedlist } 0 {{C {{CC {{CCC ccc}}}}} {A {{AA aa} {AB ab}}} {B {{BA ba} {BB bb} {BC {{BBB bbb}}}}}} Test keylist-3.15 {keylset tests} { set keyedlist {} keylset keyedlist ABCDEF value1 keylset keyedlist A.SUB value2 list $keyedlist [keylkeys keyedlist] } 0 {{{ABCDEF value1} {A {{SUB value2}}}} {ABCDEF A}} Test keylist-3.16 {keylset tests} { set keyedlist {} keylset keyedlist A.SUB value1 keylset keyedlist ABCDEF value2 list $keyedlist [keylkeys keyedlist] } 0 {{{A {{SUB value1}}} {ABCDEF value2}} {A ABCDEF}} Test keylist-4.1 {keyldel tests} { set keyedlist {{keyA valueA} {keyB valueB} {keyD valueD}} keyldel keyedlist keyB set keyedlist } 0 {{keyA valueA} {keyD valueD}} Test keylist-4.2 {keyldel tests} { set keyedlist {{keyA valueA} {keyB valueB} {keyD valueD}} keyldel keyedlist keyB keyldel keyedlist keyA set keyedlist } 0 {{keyD valueD}} Test keylist-4.3 {keyldel tests} { set keyedlist {{keyA valueA} {keyB valueB} {keyD valueD}} keyldel keyedlist keyD keyldel keyedlist keyB keyldel keyedlist keyA set keyedlist } 0 {} Test keylist-4.4 {keyldel tests} { set keyedlist {{keyA valueA} {keyB valueB} {keyD valueD}} keyldel keyedlist keyC } 1 {key not found: "keyC"} Test keylist-4.5 {keyldel tests} { keyldel keyedlist } 1 {wrong # args: keyldel listvar key ?key ...?} Test keylist-4.6 {keyldel tests} { set keyedlist $list3 keyldel keyedlist B.BA set keyedlist } 0 {{C {{CC {{CCC ccc}}}}} {A {{AA aa} {AB ab}}} {B {{BB bb} {BC {{BBB bbb}}}}}} Test keylist-4.7 {keyldel tests} { keyldel keyedlist A.AA set keyedlist } 0 {{C {{CC {{CCC ccc}}}}} {A {{AB ab}}} {B {{BB bb} {BC {{BBB bbb}}}}}} Test keylist-4.8 {keyldel tests} { keyldel keyedlist C.CC.CCC set keyedlist } 0 {{A {{AB ab}}} {B {{BB bb} {BC {{BBB bbb}}}}}} Test keylist-4.9 {keyldel tests} { keyldel keyedlist A.AB set keyedlist } 0 {{B {{BB bb} {BC {{BBB bbb}}}}}} Test keylist-4.10 {keyldel tests} { keyldel keyedlist B.BC.BBB set keyedlist } 0 {{B {{BB bb}}}} Test keylist-4.11 {keyldel tests} { keyldel keyedlist B.BB set keyedlist } 0 {} Test keylist-4.12 {keyldel tests} { set keyedlist $list3 keyldel keyedlist B set keyedlist } 0 {{C {{CC {{CCC ccc}}}}} {A {{AA aa} {AB ab}}}} Test keylist-4.13 {keyldel tests} { keyldel keyedlist A set keyedlist } 0 {{C {{CC {{CCC ccc}}}}}} Test keylist-4.14 {keyldel tests} { keyldel keyedlist C set keyedlist } 0 {} Test keylist-4.15 {keyldel tests} { set keyedlist $list3 keyldel keyedlist B A set keyedlist } 0 {{C {{CC {{CCC ccc}}}}}} # Handling of empty lists. set keyedlist {} Test keylist-5.1 {empty keyed list tests} { keylget keyedlist } 0 {} Test keylist-5.2 {empty keyed list tests} { keylkeys keyedlist } 0 {} Test keylist-5.3 {empty keyed list tests} { keylget keyedlist A } 1 {key "A" not found in keyed list} set keyedlist { } Test keylist-5.4 {empty keyed list tests} { keylget keyedlist } 0 {} Test keylist-5.5 {empty keyed list tests} { keylkeys keyedlist } 0 {} Test keylist-5.6 {empty keyed list tests} { keylget keyedlist A } 1 {key "A" not found in keyed list} # # Some stress cases. Cause table expansions, etc. # # # Proc to recurse through generated keyed list name space and execute # commands. Variables `keyedList', `key' and `depth' maybe use in the # commands. # proc PoundKeyedList {klVar depth field entrySizes leafCmd branchCmd} { upvar $klVar keyedList if [lempty $field] { set separ "" } else { set separ . } set keybase [ctype char [expr [ctype ord A]+$depth]] for {set keyIdx 0} {$keyIdx < [lindex $entrySizes 0]} {incr keyIdx} { set key "${field}${separ}${keybase}_${keyIdx}" if {[llength $entrySizes] > 1} { eval $branchCmd PoundKeyedList keyedList [expr $depth + 1] $key \ [lrange $entrySizes 1 end] $leafCmd $branchCmd } else { eval $leafCmd } } } # # Build, access and delete elements from a keyed list which is wide at the top. # Test keylist-6.0 {large list tests} { set keyedList {} PoundKeyedList keyedList 0 "" {50 2 3} { keylset keyedList $key VAL_$key } {} PoundKeyedList keyedList 0 "" {50 2 3} { if ![cequal [keylget keyedList $key] VAL_$key] { error "got value of \"[keylget keyedList $key]\", \ expected \"VAL_$key\"" } } {} PoundKeyedList keyedList 0 "" {50 2 3} { keyldel keyedList $key } {} set keyedList } 0 {} # # Build, access and delete elements from a keyed list which is wide at the top. # Do it with odd keys then even keys, reverse order of access, then again for # delete. # Test keylist-6.1 {large list tests} { set keyedList {} PoundKeyedList keyedList 0 "" {50 2 3} { if {($keyIdx % 2) == 0} { keylset keyedList $key VAL_$key } } {} PoundKeyedList keyedList 0 "" {50 2 3} { if {($keyIdx % 2) == 1} { keylset keyedList $key VAL_$key } } {} PoundKeyedList keyedList 0 "" {50 2 3} { if {($keyIdx % 2) == 1} { if ![cequal [keylget keyedList $key] VAL_$key] { error "got value of \"[keylget keyedList $key]\", \ expected \"VAL_$key\"" } } } {} PoundKeyedList keyedList 0 "" {50 2 3} { if {($keyIdx % 2) == 0} { if ![cequal [keylget keyedList $key] VAL_$key] { error "got value of \"[keylget keyedList $key]\", \ expected \"VAL_$key\"" } } } {} PoundKeyedList keyedList 0 "" {50 2 3} { if {($keyIdx % 2) == 0} { keyldel keyedList $key } } {} PoundKeyedList keyedList 0 "" {50 2 3} { if {($keyIdx % 2) == 1} { keyldel keyedList $key } } {} set keyedList } 0 {} # # Build, access and delete elements from a keyed list which is wide in the # middle. # Test keylist-6.2 {large list tests} { set keyedList {} PoundKeyedList keyedList 0 "" {10 30 5} { keylset keyedList $key VAL_$key } {} PoundKeyedList keyedList 0 "" {10 30 5} { if ![cequal [keylget keyedList $key] VAL_$key] { error "got value of \"[keylget keyedList $key]\", \ expected \"VAL_$key\"" } } {} PoundKeyedList keyedList 0 "" {10 30 5} { keyldel keyedList $key } {} set keyedList } 0 {} # # Build, access and delete elements from a keyed list which is deep. # Test keylist-6.3 {large list tests} { set keyedList {} PoundKeyedList keyedList 0 "" {3 3 3 3 3 3} { keylset keyedList $key VAL_$key } {} PoundKeyedList keyedList 0 "" {3 3 3 3 3 3} { if ![cequal [keylget keyedList $key] VAL_$key] { error "got value of \"[keylget keyedList $key]\", \ expected \"VAL_$key\"" } } {} PoundKeyedList keyedList 0 "" {3 3 3 3 3 3} { keyldel keyedList $key } {} set keyedList } 0 {} # # Shared obj subkeys - watch for entries/hash consistency # Test keylist-7.1 {shared obj key} { set zz {} keylset zz aa.foo 1 # this will cause the subkey to have a shared obj, causing call to # DupSharedKeyListChild on next set keylget zz aa - keylset zz aa.bar 1 keyldel zz aa.foo keyldel zz aa.bar set zz } 0 {} # cleanup ::tcltest::cleanupTests return tclx8.4-8.4.1.orig/tests/cmdloop.test0000644000000000000000000000412312046313167014260 0ustar # # cmdloop.test # # Tests for the commandloop command. #--------------------------------------------------------------------------- # Copyright 1992-1999 Karl Lehenbauer and Mark Diekhans. # # Permission to use, copy, modify, and distribute this software and its # documentation for any purpose and without fee is hereby granted, provided # that the above copyright notice appear in all copies. Karl Lehenbauer and # Mark Diekhans make no representations about the suitability of this # software for any purpose. It is provided "as is" without express or # implied warranty. #------------------------------------------------------------------------------ # $Id: cmdloop.test,v 1.2 2002/04/02 02:29:43 hobbs Exp $ #------------------------------------------------------------------------------ # if {[cequal [info procs Test] {}]} { source [file join [file dirname [info script]] testlib.tcl] } Test cmdloop-1.1 {commandloop tests} { commandloop xxx } 1 {wrong # args: commandloop ?-async? ?-interactive on|off|tty? ?-prompt1 cmd? ?-prompt2 cmd? ?-endcommand cmd?} Test cmdloop-1.2 {commandloop tests} { commandloop -arf } 1 {unknown option "-arf", expected one of "-async", "-interactive", "-prompt1", "-prompt2", or "-endcommand"} Test cmdloop-1.3 {commandloop tests} { commandloop -interactive foo } 1 {expected boolean value but got "foo"} Test cmdloop-1.4 {commandloop tests} { commandloop -prompt1 } 1 {argument required for -prompt1 option} Test cmdloop-1.5 {commandloop tests} { commandloop -prompt2 } 1 {argument required for -prompt2 option} Test cmdloop-1.6 {commandloop tests} { commandloop -prompt2 x y } 1 {wrong # args: commandloop ?-async? ?-interactive on|off|tty? ?-prompt1 cmd? ?-prompt2 cmd? ?-endcommand cmd?} Test cmdloop-1.7 {commandloop tests} { commandloop -endcommand } 1 {argument required for -endcommand option} # # More tests need. To make this easy, we need a quit command to exit # a command loop without exiting the interp. Quit must only exit a # command loop associated with a particular interp, so setting a # global is not the easy way to go. # tclx8.4-8.4.1.orig/tests/cmdtrace.test0000644000000000000000000001542312046313167014412 0ustar # # cmdtrace.test # # Tests for the cmdtrace command. #--------------------------------------------------------------------------- # Copyright 1992-1999 Karl Lehenbauer and Mark Diekhans. # # Permission to use, copy, modify, and distribute this software and its # documentation for any purpose and without fee is hereby granted, provided # that the above copyright notice appear in all copies. Karl Lehenbauer and # Mark Diekhans make no representations about the suitability of this # software for any purpose. It is provided "as is" without express or # implied warranty. #------------------------------------------------------------------------------ # $Id: cmdtrace.test,v 1.5 2005/11/18 00:01:35 hobbs Exp $ #------------------------------------------------------------------------------ # if {[cequal [info procs Test] {}]} { source [file join [file dirname [info script]] testlib.tcl] } # # Proc to do something to trace. # proc DoStuff {} { set foo [replicate "-TheString-" 10] set baz $foo set wap 1 if {$wap} { set wap 0 } else { set wap 1 } } proc DoStuff1 {} {DoStuff} proc DoStuff2 {} {DoStuff1} proc DoStuff3 {} {DoStuff2} proc DoStuff4 {} {DoStuff3} # # Proc to retrieve the output of a trace. It determines the level of the first # line. This is used to strip off level number and identation from each line. # so that all lines will be indented the same amount. It also closes the # trace file. proc GetTrace {cmdtraceFH} { set result {} seek $cmdtraceFH 0 start if {([gets $cmdtraceFH line] < 2) || ([scan $line "%d" level] != 1)} { error "*Incorrect format for first line of the trace*" } set nuke [expr ($level*2)+3] seek $cmdtraceFH 0 start while {[gets $cmdtraceFH line] >= 0} { set linelen [clength $line] if {$linelen == 0} { continue} if {$linelen < $nuke} { error "invalid trace line: `$line'"} append result "[crange $line $nuke end]\n" } close $cmdtraceFH return $result } Test cmdtrace-1.1 {command trace: evaluated, truncated} { set cmdtraceFH [open CMDTRACE.OUT w+] cmdtrace on $cmdtraceFH DoStuff4 cmdtrace off GetTrace $cmdtraceFH } 0 {DoStuff4 DoStuff3 DoStuff2 DoStuff1 DoStuff replicate -TheString- 10 set foo -TheString--TheString--TheString--TheStr... set baz -TheString--TheString--TheString--TheStr... set wap 1 if $wap {\n set wap 0\n } else {\n set wap 1\n } set wap 0 cmdtrace off } Test cmdtrace-1.2 {command trace: not evaluated, truncated} { set cmdtraceFH [open CMDTRACE.OUT w+] cmdtrace on $cmdtraceFH noeval DoStuff4 cmdtrace off GetTrace $cmdtraceFH } 0 "DoStuff4\\n DoStuff3 DoStuff2 DoStuff1 DoStuff replicate \"-TheString-\" 10 set foo \[replicate \"-TheString-\" 10\] set baz \$foo set wap 1 if {\$wap} {\\n set wap 0\\n } else \{\\n set wap 1... set wap 0 cmdtrace off\\n " Test cmdtrace-1.3 {command trace: evaluated, not truncated} { set cmdtraceFH [open CMDTRACE.OUT w+] cmdtrace on $cmdtraceFH notruncate DoStuff4 cmdtrace off GetTrace $cmdtraceFH } 0 {DoStuff4 DoStuff3 DoStuff2 DoStuff1 DoStuff replicate -TheString- 10 set foo -TheString--TheString--TheString--TheString--TheString--TheString--TheString--TheString--TheString--TheString- set baz -TheString--TheString--TheString--TheString--TheString--TheString--TheString--TheString--TheString--TheString- set wap 1 if $wap {\n set wap 0\n } else {\n set wap 1\n } set wap 0 cmdtrace off } Test cmdtrace-1.4 {command trace: not evaluated, not truncated} { set cmdtraceFH [open CMDTRACE.OUT w+] cmdtrace on $cmdtraceFH notruncate noeval DoStuff4 cmdtrace off GetTrace $cmdtraceFH } 0 {DoStuff4\n DoStuff3 DoStuff2 DoStuff1 DoStuff replicate "-TheString-" 10 set foo [replicate "-TheString-" 10] set baz $foo set wap 1 if {$wap} {\n set wap 0\n } else {\n set wap 1\n } set wap 0 cmdtrace off\n } Test cmdtrace-2.1 {command trace argument error checking} { cmdtrace foo } 1 {expected integer but got "foo"} Test cmdtrace-2.2 {command trace argument error checking} { cmdtrace on foo } 1 {invalid option: expected one of "noeval", "notruncate", "procs", "command", or a file id} Test cmdtrace-2.3 {command trace argument error checking} { catch {close file20} cmdtrace on file20 } 1 {can not find channel named "file20"} Test cmdtrace-2.5 {command trace argument error checking} { cmdtrace on command } 1 {command option requires an argument} Test cmdtrace-2.6 {command trace argument error checking} { cmdtrace on file20 command arf } 1 {can not specify both the command option and a file handle} # cmdtrace callback. Can't log level as it might change depending on how # the test is run. set traceout {} proc ctcallback {clientdata command argv evalLevel procLevel args} { global traceout expr $evalLevel+1 ;# Error if not a number expr $procLevel+1 lappend traceout [list $clientdata $command $argv $args] catch {badcommand} } Test cmdtrace-3.1 {command trace argument error checking} { set errorInfo ERRORINFO set errorCode ERRORCODE cmdtrace on command "ctcallback CD" DoStuff4 cmdtrace off lappend traceout $errorInfo $errorCode set traceout } 0 [list {CD {{DoStuff4 }} DoStuff4 {}} \ {CD DoStuff3 DoStuff3 {}} \ {CD DoStuff2 DoStuff2 {}} \ {CD DoStuff1 DoStuff1 {}} \ {CD DoStuff DoStuff {}} \ {CD {{replicate "-TheString-" 10}} {{replicate -TheString- 10}} {}} \ {CD {{set foo [replicate "-TheString-" 10]}} {{set foo -TheString--TheString--TheString--TheString--TheString--TheString--TheString--TheString--TheString--TheString-}} {}} \ {CD {{set baz $foo}} {{set baz -TheString--TheString--TheString--TheString--TheString--TheString--TheString--TheString--TheString--TheString-}} {}} \ {CD {{set wap 1}} {{set wap 1}} {}} \ {CD {{if {$wap} { set wap 0 } else { set wap 1 }}} {{if {$wap} { set wap 0 } else { set wap 1 }}} {}} \ {CD {{set wap 0}} {{set wap 0}} {}} \ {CD {{cmdtrace off }} {{cmdtrace off}} {}}\ ERRORINFO \ ERRORCODE] test cmdtrace-3.2 {command trace argument error checking} { removeFile script makeFile { package require Tclx puts [list [catch { cmdtrace on command {foo $NOTDEFINED} info globals } msg] $msg] } {script} exec $::tcltest::tcltest script } {1 {can't read "NOTDEFINED": no such variable}} TestRemove CMDTRACE.OUT # cleanup ::tcltest::cleanupTests return tclx8.4-8.4.1.orig/tests/fcntl.test0000644000000000000000000001133312046313166013731 0ustar # # fcntl.test # # Tests for the fcntl command. #--------------------------------------------------------------------------- # Copyright 1992-1999 Karl Lehenbauer and Mark Diekhans. # # Permission to use, copy, modify, and distribute this software and its # documentation for any purpose and without fee is hereby granted, provided # that the above copyright notice appear in all copies. Karl Lehenbauer and # Mark Diekhans make no representations about the suitability of this # software for any purpose. It is provided "as is" without express or # implied warranty. #------------------------------------------------------------------------------ # $Id: fcntl.test,v 1.3 2002/04/04 06:10:30 hobbs Exp $ #------------------------------------------------------------------------------ # if {[cequal [info procs Test] {}]} { source [file join [file dirname [info script]] testlib.tcl] } close [open FCNTL1.TMP w] close [open FCNTL2.TMP w] close [open FCNTL3.TMP w] set testRWFH [open FCNTL1.TMP r+] set testRFH [open FCNTL2.TMP r] set testWFH [open FCNTL3.TMP w] pipe testRPH testWPH test fcntl-1.1 {fcntl tests} { fcntl $testRWFH RDONLY } 0 test fcntl-1.2 {fcntl tests} { fcntl $testRWFH WRONLY } 0 test fcntl-1.3 {fcntl tests} { fcntl $testRWFH RDWR } 1 test fcntl-1.4 {fcntl tests} { fcntl $testRWFH READ } 1 test fcntl-1.5 {fcntl tests} { fcntl $testRWFH WRITE } 1 test fcntl-1.6 {fcntl tests} { fcntl $testRFH RDONLY } 1 test fcntl-1.7 {fcntl tests} { fcntl $testRFH WRONLY } 0 test fcntl-1.8 {fcntl tests} { fcntl $testRFH RDWR } 0 test fcntl-1.9 {fcntl tests} { fcntl $testRFH READ } 1 test fcntl-1.10 {fcntl tests} { fcntl $testRFH WRITE } 0 test fcntl-1.11 {fcntl tests} { fcntl $testWFH RDONLY } 0 test fcntl-1.12 {fcntl tests} { fcntl $testWFH WRONLY } 1 test fcntl-1.13 {fcntl tests} { fcntl $testWFH RDWR } 0 test fcntl-1.14 {fcntl tests} { fcntl $testWFH READ } 0 test fcntl-1.15 {fcntl tests} { fcntl $testWFH WRITE } 1 test fcntl-2.1 {fcntl tests} { fcntl $testRWFH CLOEXEC 1 fcntl $testRWFH CLOEXEC } 1 test fcntl-2.2 {fcntl tests} { fcntl $testRWFH CLOEXEC 0 fcntl $testRWFH CLOEXEC } 0 test fcntl-2.3 {fcntl tests} { fcntl $testRPH NONBLOCK 1 list [fcntl $testRPH NONBLOCK] [fconfigure $testRPH -blocking] } {1 0} test fcntl-2.4 {fcntl tests} unixOnly { fcntl $testRWFH append 1 fcntl $testRWFH append } 1 test fcntl-2.5 {fcntl tests} unixOnly { fcntl $testRWFH APPEND 0 fcntl $testRWFH append } 0 test fcntl-2.5.1 {fcntl tests} pcOnly { list [catch {fcntl $testRWFH APPEND 0} msg] $msg } {1 {append mode is not available on MS Windows}} test fcntl-3.1 {fcntl tests} { fcntl $testRPH NONBLOCK 0 list [fcntl $testRPH nonBlock] [fconfigure $testRPH -blocking] } {0 1} test fcntl-3.2 {fcntl tests} { fcntl $testRWFH NOBUF 1 list [fcntl $testRWFH NObuf] [fconfigure $testRWFH -buffering] } {1 none} close $testRWFH close $testRFH close $testWFH # Reopen, can not have both nobuf and linebuf set testRWFH [open FCNTL1.TMP w] test fcntl-4.1 {fcntl tests} { fcntl $testRWFH LINEBUF 1 list [fcntl $testRWFH LINEBUF] [fconfigure $testRWFH -buffering] } {1 line} test fcntl-5.1 {fcntl tests} { list [catch {fcntl $testRWFH a b c} msg] $msg } {1 {wrong # args: fcntl handle attribute ?value?}} test fcntl-5.2 {fcntl tests} { list [catch {fcntl $testRWFH BAZ 1} msg] $msg } {1 {unknown attribute name "BAZ", expected one of RDONLY, WRONLY, RDWR, READ, WRITE, APPEND, CLOEXEC, NONBLOCK, LINEBUF, NOBUF, or KEEPALIVE}} test fcntl-5.3 {fcntl tests} { list [catch {fcntl $testRWFH APPEND FOO} msg] $msg } {1 {expected boolean value but got "FOO"}} close $testRWFH test fcntl-5.4 {fcntl tests} { list [catch {fcntl $testRWFH RDONLY} msg] $msg } [list 1 "can not find channel named \"$testRWFH\""] close $testRPH close $testWPH # # Tests for socket related controls. # set doSocketTests 0 # FIX: Should be an explict test for NT. if {[cequal $tcl_platform(platform) unix] || ![cequal $tcl_platform(os) "Windows 95"]} { if {[catch {close [socket [id host] echo]; set doSocketTests 1} msg]} { puts "*************************************************************" puts "Unable to connect to the \"echo\" server:" puts "$msg." puts "Some tests skipped." puts "*************************************************************" } } if $doSocketTests { set sockFH [socket [id host] echo] test fcntl-6.1 {fcntl socket tests} { fcntl $sockFH KEEPALIVE 1 fcntl $sockFH KEEPALIVE } 1 test fcntl-6.2 {fcntl socket tests} { fcntl $sockFH KEEPALIVE 0 fcntl $sockFH KEEPALIVE } 0 close $sockFH } TestRemove FCNTL1.TMP FCNTL2.TMP FCNTL3.TMP tclx8.4-8.4.1.orig/tests/lmatch.test0000644000000000000000000000354012046313167014075 0ustar # # lmatch.test # # Tests for the lmatch command. if {[cequal [info procs Test] {}]} { source [file join [file dirname [info script]] testlib.tcl] } set x {abcd bbcd 123 234 345 445} Test lmatch-1.1 {lmatch command} { lmatch $x 123 } 0 "123" Test lmatch-1.2 {lmatch command} { lmatch $x 3456 } 0 "" Test lmatch-1.3 {lmatch command} { lmatch $x *5 } 0 "345 445" Test lmatch-1.4 {lmatch command} { lmatch $x *bc* } 0 "abcd bbcd" Test lmatch-1.5 {lmatch command} { lmatch {} *bc* } 0 {} Test lmatch-2.1 {search modes} { lmatch -exact {xyz bbcc *bc*} *bc* } 0 {*bc*} Test lmatch-2.2 {search modes} { lmatch -exact {b.x ^bc xy bcx ^bc} ^bc } 0 {^bc ^bc} Test lmatch-2.2.1 {search modes} { lmatch -exact [list a\0A a b\0a a\0A] a\0A } 0 [list a\0A a\0A] Test lmatch-2.3 {search modes} { lmatch -regexp {xyz bbcc *bc*} *bc* } 1 {couldn't compile regular expression pattern: quantifier operand invalid} Test lmatch-2.4 {search modes} { lmatch -regexp {b.x ^bc xy bcx bca} ^bc } 0 {bcx bca} Test lmatch-2.5 {search modes} { lmatch -glob {xyz bbcc *bc* abcd} *bc* } 0 {bbcc *bc* abcd} Test lmatch-2.6 {search modes} { lmatch -glob {b.x ^bc xy bcx} ^bc } 0 {^bc} Test lmatch-2.7 {search modes} { lmatch -glib {b.x bx xy bcx} b.x } 1 {bad search mode "-glib": must be -exact, -glob, or -regexp} Test lmatch-3.1 {lmatch errors} { lmatch } 1 {wrong # args: lmatch ?mode? list pattern} Test lmatch-3.2 {lmatch errors} { lmatch a } 1 {wrong # args: lmatch ?mode? list pattern} Test lmatch-3.3 {lmatch errors} { lmatch a b c } 1 {bad search mode "a": must be -exact, -glob, or -regexp} Test lmatch-3.4 {lmatch errors} { lmatch a b c d } 1 {wrong # args: lmatch ?mode? list pattern} Test lmatch-3.5 {lmatch errors} { lmatch "\{" b } 1 {unmatched open brace in list} # cleanup ::tcltest::cleanupTests return tclx8.4-8.4.1.orig/tests/lgets.test0000644000000000000000000001574112046313167013751 0ustar # # lgets.test # # Tests for the lgets command. #--------------------------------------------------------------------------- # Copyright 1992-1999 Karl Lehenbauer and Mark Diekhans. # # Permission to use, copy, modify, and distribute this software and its # documentation for any purpose and without fee is hereby granted, provided # that the above copyright notice appear in all copies. Karl Lehenbauer and # Mark Diekhans make no representations about the suitability of this # software for any purpose. It is provided "as is" without express or # implied warranty. #------------------------------------------------------------------------------ # $Id: lgets.test,v 1.3 2002/04/04 06:10:30 hobbs Exp $ #------------------------------------------------------------------------------ # if {[cequal [info procs Test] {}]} { source [file join [file dirname [info script]] testlib.tcl] } test lgets-1.1 {lgets command} { list [catch {lgets} msg] $msg } {1 {wrong # args: lgets fileId ?varName?}} test lgets-1.2 {lgets command} { list [catch {lgets a b c} msg] $msg } {1 {wrong # args: lgets fileId ?varName?}} test lgets-1.3 {lgets command} { list [catch {lgets a} msg] $msg } {1 {can not find channel named "a"}} set f [open test2.tmp w] test lgets-1.4 {lgets command} { list [catch {lgets $f} msg] $msg } [list 1 "channel \"$f\" wasn't opened for reading"] catch {close $f} set test2data \ [replicate abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ 100] set f [open test2.tmp w] puts $f $test2data close $f test lgets-1.5 {lgets command with long line} { set f [open test2.tmp] set x [lgets $f] close $f set x } $test2data test lgets-1.6 {lgets command with long line} { set f [open test2.tmp] set x [lgets $f y] close $f list $x $y } [list [clength $test2data] $test2data] test lgets-1.7 {lgets command with EOF in list element} { set f [open test2.tmp w] puts $f "Test1 \{Test2 " nonewline close $f set f [open test2.tmp] list [catch {lgets $f} msg] $msg } {1 {EOF encountered before newline while reading list from channel}} catch {close $f} test lgets-1.8 {lgets command with EOF in list} { set f [open test2.tmp w] puts $f "Test1\nTest2" nonewline close $f set f [open test2.tmp] set x {} set y {} lappend x [lgets $f y] $y set y {} lappend x [catch {lgets $f y} r] $r $y close $f set x } {5 Test1 1 {EOF encountered before newline while reading list from channel} Test2} test lgets-2.1 {lgets command} { catch {unset data} set data(0) [list aaa b cccc] set data(1) [list aaaa \" ccc] set data(2) [list aaaaa \" cc] set data(3) [list aaaaa \"\" \} \{ \n c] set data(4) [list bcad \n defg \n nypq] set data(5) [list {BCAD {AAA BBB CCC} defg nypq}] set data(6) [list [replicate ABD 200] "\n" [replicate XYZ 100]] set data(7) [list [replicate ABD 255] "\n" [replicate XYZ 100]] set data(8) [list [replicate ABD 256] "\n" [replicate XYZ 100]] set data(9) [list [replicate "AAA\n \{B \"BB" 100]] set fh [open test1.tmp w] foreach idx [lsort -integer [array names data]] { puts $fh $data($idx) } close $fh set fh [open test1.tmp] concat {} } {} test lgets-2.2 {lgets command} { lgets $fh } $data(0) test lgets-2.3 {lgets command} { lgets $fh retvar set retvar } $data(1) test lgets-2.4 {lgets command} { lgets $fh } $data(2) test lgets-2.5 {lgets command} { lgets $fh retvar set retvar } $data(3) test lgets-2.6 {lgets command} { lgets $fh } $data(4) test lgets-2.7 {lgets command} { lgets $fh retvar set retvar } $data(5) test lgets-2.8 {lgets command} { lgets $fh retvar set retvar } $data(6) test lgets-2.9 {lgets command} { lgets $fh retvar set retvar } $data(7) test lgets-2.10 {lgets command} { lgets $fh retvar set retvar } $data(8) test lgets-2.11 {lgets command} { lgets $fh retvar set retvar } $data(9) catch {close $fh} unset data # Make sure odd lists work. set data [list ERR_REQUEST_PROCESSOR_FAILURE " {sc ...\""] test lgets-3.1 {lgets command} { set fh [open test1.tmp w+] puts $fh $data seek $fh 0 lgets $fh } $data catch {close $fh} # Easy test to make sure basic non-blocked channel works, even though we # don't actually test the no-data case. # FIX: Doesn't work right on Win32. if [cequal $tcl_platform(platform) windows] { echo " * lgets tests not completely ported to Win32, some tests skipped" TestRemove test1.tmp test2.tmp return } pipe rpipe wpipe fconfigure $rpipe -blocking 0 test lgets-4.1 {lgets on non-blocked channel} {tempNotPc} { puts $wpipe $data flush $wpipe list [catch {lgets $rpipe} msg] $msg } {1 {channel is non-blocking; not currently supported by the lgets command}} test lgets-4.2 {lgets on non-blocked channel} {tempNotPc} { puts $wpipe $data flush $wpipe catch {unset x} list [catch {lgets $rpipe x} msg] $msg } {1 {channel is non-blocking; not currently supported by the lgets command}} catch {close $rpipe} catch {close $wpipe} unset data # # Binary data # test lgets-5.1 {lgets with binary data} { catch {unset data} set data(0) [list aaa b cc\0cc] set data(1) [list aaaa \" \0\0 ccc] set data(2) [list aaaaa \" cc] set data(3) [list aaaaa \"\" \} [replicate \0\1\0 5] \{ \n c] set data(4) [list bcad \n defg \n nypq] set data(5) [list BCAD "AAA \0 BBB CCC" " defg \0\0\0" nypq] set data(6) [list [replicate ABD 200] "\n" [replicate XYZ 100]] set data(7) [list [replicate ABD 255] "\n" [replicate XYZ 100]] set data(8) [list [replicate ABD 256] "\n" [replicate XYZ 100]] set data(9) [list [replicate "AAA\n \{B \"BB" 100]] set fh [open test1.tmp w] foreach idx [lsort -integer [array names data]] { puts $fh $data($idx) } close $fh set fh [open test1.tmp] concat {} } {} test lgets-5.2 {lgets with binary data} { lgets $fh } $data(0) test lgets-5.3 {lgets with binary data} { lgets $fh retvar set retvar } $data(1) test lgets-5.4 {lgets with binary data} { lgets $fh } $data(2) test lgets-5.5 {lgets with binary data} { lgets $fh retvar set retvar } $data(3) test lgets-5.6 {lgets with binary data} { lgets $fh } $data(4) test lgets-5.7 {lgets with binary data} { lgets $fh retvar set retvar } $data(5) test lgets-5.8 {lgets with binary data} { lgets $fh retvar set retvar } $data(6) test lgets-5.9 {lgets with binary data} { lgets $fh retvar set retvar } $data(7) test lgets-5.10 {lgets with binary data} { lgets $fh retvar set retvar } $data(8) test lgets-5.11 {lgets with binary data} { lgets $fh retvar set retvar } $data(9) catch {close $fh} unset data test lgets-6.0 {lgets corner cases} { set fh [open test2.tmp w+] puts $fh [list {\\server} {\home} {foo\}}] seek $fh 0 lgets $fh inlist close $fh set inlist } [list {\\server} {\home} {foo\}}] TestRemove test1.tmp test2.tmp # cleanup ::tcltest::cleanupTests return tclx8.4-8.4.1.orig/tests/loop.test0000644000000000000000000000561412046313167013602 0ustar # # loop.test # # Tests for the loop command. #--------------------------------------------------------------------------- # Copyright 1992-1999 Karl Lehenbauer and Mark Diekhans. # # Permission to use, copy, modify, and distribute this software and its # documentation for any purpose and without fee is hereby granted, provided # that the above copyright notice appear in all copies. Karl Lehenbauer and # Mark Diekhans make no representations about the suitability of this # software for any purpose. It is provided "as is" without express or # implied warranty. #------------------------------------------------------------------------------ # $Id: loop.test,v 1.2 2002/04/02 02:29:43 hobbs Exp $ #------------------------------------------------------------------------------ # if {[cequal [info procs Test] {}]} { source [file join [file dirname [info script]] testlib.tcl] } Test loop-1.1 {loop tests} { set a {} set i 1 loop i 1 6 { set a [concat $a $i] } set a } 0 {1 2 3 4 5} Test loop-1.2 {loop tests} { set a {} loop i 1 6 { if {$i == 4} { continue} set a [concat $a $i] } set a } 0 {1 2 3 5} Test loop-1.3 {loop tests} { set a {} loop i 1 6 { if $i==4 break set a [concat $a $i] } set a } 0 {1 2 3} Test loop-1.4 {loop tests} { loop 1 2 3 } 1 {wrong # args: loop var first limit ?incr? command} Test loop-1.5 {loop tests} { loop 1 2 3 4 5 6 } 1 {wrong # args: loop var first limit ?incr? command} Test loop-1.6 {loop tests} { set a {} loop i 1 6 { set a [concat $a $i] set i 100 } set a } 0 {1 2 3 4 5} Test loop-1.7 {loop tests} { set a {} loop i 1 6 2 { set a [concat $a $i] } set a } 0 {1 3 5} Test loop-1.8 {loop tests} { set a {} set i 1 loop i 6 1 -1 { set a [concat $a $i] } set a } 0 {6 5 4 3 2} Test loop-1.9 {loop tests} { set a {} loop i 6 1 -1 { if $i==4 { continue} set a [concat $a $i] } set a } 0 {6 5 3 2} Test loop-1.10 {loop tests} { set a {} loop i 6 1 -1 { if {$i == 4} { break} set a [concat $a $i] } set a } 0 {6 5} Test loop-1.11 {loop tests} { set j 0 loop i 65536 65556 { incr j } set j } 0 20 Test loop-1.12 {loop tests} { set j 0 loop i 65556 65536 -1 { incr j 1 } set j } 0 20 Test loop-1.13 {loop tests} { set j 0 loop i 0 655360 65536 { incr j 1 } set j } 0 10 Test loop-1.14 {loop tests} { set j 0 loop i 655360 0 -65536 { incr j 1 } set j } 0 10 Test loop-1.15 {loop tests} { set a {} set i 1 loop i 3*2 0+1 10-11 { set a [concat $a $i] } set a } 0 {6 5 4 3 2} Test loop-2.1 {loop test} { loop i 0 5 {error "an error"} } 1 {an error} # cleanup ::tcltest::cleanupTests return tclx8.4-8.4.1.orig/tests/chmod.test0000644000000000000000000004770612046313167013733 0ustar # # chmod.test # # Tests for the chmod, chown and chgrp commands. #--------------------------------------------------------------------------- # Copyright 1992-1999 Karl Lehenbauer and Mark Diekhans. # # Permission to use, copy, modify, and distribute this software and its # documentation for any purpose and without fee is hereby granted, provided # that the above copyright notice appear in all copies. Karl Lehenbauer and # Mark Diekhans make no representations about the suitability of this # software for any purpose. It is provided "as is" without express or # implied warranty. #------------------------------------------------------------------------------ # $Id: chmod.test,v 1.3 2002/04/04 06:10:30 hobbs Exp $ #------------------------------------------------------------------------------ # if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import ::tcltest::* } if {[cequal [info procs Test] {}]} { source [file join [file dirname [info script]] testlib.tcl] } if [cequal $tcl_platform(platform) windows] { echo " * The chmod, chown and chgrp commands have not been ported to Win32" return } #----------------------------------------------------------------------------- # This routine to the the mode of a file. It is returned formated in octal. proc GetMode {filename} { file stat $filename stat return [format "%o" [expr {$stat(mode) & 07777}]] } #----------------------------------------------------------------------------- # Certain Unix systems don't handle chmod the same. This routine test if the # system chmod produces the expected results. # o mode - symbolic mode to set the file to. # o args - list of valid expected result from ls. # proc CheckChmod {mode args} { global chmodTestsSkipped set stat 0 if {[catch { chmod 000 CHECK.TMP exec chmod $mode CHECK.TMP set sysMode [lindex [exec ls -l CHECK.TMP] 0] }] == 0} { if {[lsearch -exact $args $sysMode] >= 0} { set stat 1 } } if !$stat { incr chmodTestsSkipped } return $stat } global chmodTestsSkipped set chmodTestsSkipped 0 #----------------------------------------------------------------------------- # Procedure to return the uid of a file. proc GetUID {file} { file stat $file stat return $stat(uid) } #----------------------------------------------------------------------------- # Procedure to return the gid of a file. proc GetGID {file} { file stat $file stat return $stat(gid) } #----------------------------------------------------------------------------- # Procedure to return the uid and gid of a file. proc GetUIDGID {file} { file stat $file stat return [list $stat(uid) $stat(gid)] } #----------------------------------------------------------------------------- # If a user does not have a group name assigned, then some tests will not work, # just blow off the tests and let the user make things right. if {[catch {id group}] != 0} { echo "User '[id user]' does not have group name. Chmod tests skipped" return } #----------------------------------------------------------------------------- # Purge existing test files and recreate them. # proc SetUpTestFiles {} { foreach f {CHECK.TMP CHMOD.TMP CHMOD2.TMP} { catch { chmod a+w $f file delete $f } close [open $f w] } } SetUpTestFiles # Set the umask so that no bits are masked. Some system chmods use umask # if u, g, o or a are not specified in a symbolic chmod. umask 000 test chmod-1.1 {chmod absolute mode tests} { chmod 0000 CHMOD.TMP chmod 0101 CHMOD.TMP GetMode CHMOD.TMP } {101} test chmod-1.2 {chmod absolute mode tests} { chmod 0000 CHMOD.TMP chmod 0010 CHMOD.TMP GetMode CHMOD.TMP } {10} test chmod-1.3 {chmod absolute mode tests} { chmod 0000 CHMOD.TMP chmod 0777 CHMOD.TMP GetMode CHMOD.TMP } {777} test chmod-1.4 {chmod absolute mode tests} { chmod 0000 CHMOD.TMP chmod 0666 CHMOD.TMP GetMode CHMOD.TMP } {666} test chmod-1.5 {chmod absolute mode tests} { chmod 0000 CHMOD.TMP chmod 0705 CHMOD.TMP GetMode CHMOD.TMP } {705} test chmod-1.7 {chmod absolute mode tests} { chmod 0000 CHMOD.TMP chmod 04111 CHMOD.TMP GetMode CHMOD.TMP } {4111} test chmod-1.9 {chmod absolute mode tests} {need_fchmod} { chmod 0600 CHMOD.TMP set fh [open CHMOD.TMP w] chmod -fileid 0000 $fh chmod -fileid 0101 $fh close $fh GetMode CHMOD.TMP } {101} test chmod-1.10 {chmod absolute mode tests} {need_fchmod} { chmod 0600 CHMOD.TMP set fh [open CHMOD.TMP w] chmod -fileid 0000 $fh chmod -fileid 0010 $fh close $fh GetMode CHMOD.TMP } {10} test chmod-1.11 {chmod absolute mode tests} {need_fchmod} { chmod 0600 CHMOD.TMP set fh [open CHMOD.TMP w] chmod -fileid 0000 $fh chmod -fileid 0777 $fh close $fh GetMode CHMOD.TMP } {777} test chmod-1.12 {chmod absolute mode tests} {need_fchmod} { chmod 0600 CHMOD.TMP set fh [open CHMOD.TMP w] chmod -fileid 0000 $fh chmod -fileid 0666 $fh close $fh GetMode CHMOD.TMP } {666} test chmod-1.13 {chmod absolute mode tests} {need_fchmod} { chmod 0600 CHMOD.TMP set fh [open CHMOD.TMP w] chmod -fileid 0000 $fh chmod -fileid 0705 $fh close $fh GetMode CHMOD.TMP } {705} test chmod-1.14 {chmod absolute mode tests} {need_fchmod} { chmod 0600 CHMOD.TMP set fh [open CHMOD.TMP w] chmod -fileid 0000 $fh chmod -fileid 04111 $fh close $fh GetMode CHMOD.TMP } {4111} test chmod-2.1 {chmod absolute integer mode tests} { chmod 0 {CHMOD.TMP CHMOD2.TMP} chmod 65 {CHMOD.TMP CHMOD2.TMP} list [GetMode CHMOD.TMP] [GetMode CHMOD2.TMP] } {101 101} test chmod-2.2 {chmod absolute integer mode tests} { chmod 0 {CHMOD.TMP CHMOD2.TMP} chmod 8 {CHMOD.TMP CHMOD2.TMP} list [GetMode CHMOD.TMP] [GetMode CHMOD2.TMP] } {10 10} test chmod-2.3 {chmod absolute integer mode tests} { chmod 0 {CHMOD.TMP CHMOD2.TMP} chmod 511 {CHMOD.TMP CHMOD2.TMP} list [GetMode CHMOD.TMP] [GetMode CHMOD2.TMP] } {777 777} test chmod-2.4 {chmod absolute integer mode tests} { chmod 0 {CHMOD.TMP CHMOD2.TMP} chmod 438 {CHMOD.TMP CHMOD2.TMP} list [GetMode CHMOD.TMP] [GetMode CHMOD2.TMP] } {666 666} test chmod-2.5 {chmod absolute integer mode tests} { chmod 0 {CHMOD.TMP CHMOD2.TMP} chmod 453 {CHMOD.TMP CHMOD2.TMP} list [GetMode CHMOD.TMP] [GetMode CHMOD2.TMP] } {705 705} test chmod-2.6 {chmod absolute integer mode tests} { chmod 0 CHMOD.TMP chmod 2121 CHMOD.TMP GetMode CHMOD.TMP } {4111} test chmod-2.7 {chmod absolute integer mode tests} {need_fchmod} { chmod 0600 {CHMOD.TMP CHMOD2.TMP} set fh1 [open CHMOD.TMP w] set fh2 [open CHMOD2.TMP w] chmod -fileid 0 [list $fh1 $fh2] chmod -fileid 65 [list $fh1 $fh2] close $fh1 close $fh2 list [GetMode CHMOD.TMP] [GetMode CHMOD2.TMP] } {101 101} test chmod-2.8 {chmod absolute integer mode tests} {need_fchmod} { chmod 0600 {CHMOD.TMP CHMOD2.TMP} set fh1 [open CHMOD.TMP w] set fh2 [open CHMOD2.TMP w] chmod -fileid 0 [list $fh1 $fh2] chmod -fileid 8 [list $fh1 $fh2] close $fh1 close $fh2 list [GetMode CHMOD.TMP] [GetMode CHMOD2.TMP] } {10 10} test chmod-2.9 {chmod absolute integer mode tests} {need_fchmod} { chmod 0600 {CHMOD.TMP CHMOD2.TMP} set fh1 [open CHMOD.TMP w] set fh2 [open CHMOD2.TMP w] chmod -fileid 0 [list $fh1 $fh2] chmod -fileid 511 [list $fh1 $fh2] close $fh1 close $fh2 list [GetMode CHMOD.TMP] [GetMode CHMOD2.TMP] } {777 777} test chmod-2.10 {chmod absolute integer mode tests} {need_fchmod} { chmod 0600 {CHMOD.TMP CHMOD2.TMP} set fh1 [open CHMOD.TMP w] set fh2 [open CHMOD2.TMP w] chmod -fileid 0 [list $fh1 $fh2] chmod -fileid 438 [list $fh1 $fh2] close $fh1 close $fh2 list [GetMode CHMOD.TMP] [GetMode CHMOD2.TMP] } {666 666} test chmod-2.11 {chmod absolute integer mode tests} {need_fchmod} { chmod 0600 {CHMOD.TMP CHMOD2.TMP} set fh1 [open CHMOD.TMP w] set fh2 [open CHMOD2.TMP w] chmod -fileid 0 [list $fh1 $fh2] chmod -fileid 453 [list $fh1 $fh2] close $fh1 close $fh2 list [GetMode CHMOD.TMP] [GetMode CHMOD2.TMP] } {705 705} test chmod-2.12 {chmod absolute integer mode tests} {need_fchmod} { chmod 0600 {CHMOD.TMP CHMOD2.TMP} set fh [open CHMOD.TMP w] chmod -fileid 0 $fh chmod -fileid 2121 $fh close $fh GetMode CHMOD.TMP } {4111} # Test symbolic mode. test chmod-3.1 {chmod symbolic mode tests} { chmod 000 CHMOD.TMP chmod +r CHMOD.TMP GetMode CHMOD.TMP } {444} test chmod-3.2 {chmod symbolic mode tests} { chmod 000 CHMOD.TMP chmod +r CHMOD.TMP chmod +w CHMOD.TMP GetMode CHMOD.TMP } {666} test chmod-3.3 {chmod symbolic mode tests} { chmod 000 CHMOD.TMP chmod +r CHMOD.TMP chmod +w CHMOD.TMP chmod +x CHMOD.TMP GetMode CHMOD.TMP } {777} test chmod-3.4 {chmod symbolic mode tests} { chmod 000 CHMOD.TMP chmod +r CHMOD.TMP chmod +w CHMOD.TMP chmod +x CHMOD.TMP chmod -r CHMOD.TMP GetMode CHMOD.TMP } {333} test chmod-3.5 {chmod symbolic mode tests} { chmod 000 CHMOD.TMP chmod +r CHMOD.TMP chmod +w CHMOD.TMP chmod +x CHMOD.TMP chmod -r CHMOD.TMP chmod -w CHMOD.TMP GetMode CHMOD.TMP } {111} test chmod-3.6 {chmod symbolic mode tests} { chmod 000 {CHMOD.TMP CHMOD2.TMP} chmod +r {CHMOD.TMP CHMOD2.TMP} chmod +w {CHMOD.TMP CHMOD2.TMP} chmod +x {CHMOD.TMP CHMOD2.TMP} chmod -r {CHMOD.TMP CHMOD2.TMP} chmod -w {CHMOD.TMP CHMOD2.TMP} chmod -x {CHMOD.TMP CHMOD2.TMP} list [GetMode CHMOD.TMP] [GetMode CHMOD2.TMP] } {0 0} test chmod-3.7 {chmod symbolic mode tests} { chmod 000 CHMOD.TMP chmod u+x,g+x CHMOD.TMP GetMode CHMOD.TMP } {110} test chmod-3.8 {chmod symbolic mode tests} { chmod 000 {CHMOD.TMP CHMOD2.TMP} chmod u+x,g+x {CHMOD.TMP CHMOD2.TMP} chmod u-x,g-x {CHMOD.TMP CHMOD2.TMP} list [GetMode CHMOD.TMP] [GetMode CHMOD2.TMP] } {0 0} # Can't +s on some systems if [CheckChmod "ugo+x,ug+s" "---s--s--x"] { test chmod-3.9 {chmod symbolic mode tests} { chmod 000 CHMOD.TMP chmod ugo+x,ug+s CHMOD.TMP GetMode CHMOD.TMP } {6111} } test chmod-3.10 {chmod symbolic mode tests} { chmod 000 CHMOD.TMP chmod a+rwx CHMOD.TMP GetMode CHMOD.TMP } {777} test chmod-3.11 {chmod symbolic mode tests} { chmod 000 CHMOD.TMP chmod a+rwx CHMOD.TMP chmod a-rw CHMOD.TMP GetMode CHMOD.TMP } {111} test chmod-3.12 {chmod symbolic mode tests} { chmod 000 CHMOD.TMP chmod a=rwx CHMOD.TMP GetMode CHMOD.TMP } {777} test chmod-3.13 {chmod symbolic mode tests} { chmod 000 CHMOD.TMP chmod u=rwx,go=rx CHMOD.TMP GetMode CHMOD.TMP } {755} test chmod-3.14 {chmod symbolic mode tests} {need_fchmod} { chmod 0600 CHMOD.TMP set fh [open CHMOD.TMP w] chmod -fileid 000 $fh chmod -fileid +r $fh close $fh GetMode CHMOD.TMP } {444} test chmod-3.2 {chmod symbolic mode tests} {need_fchmod} { chmod 0600 CHMOD.TMP set fh [open CHMOD.TMP w] chmod -fileid 000 $fh chmod -fileid +r $fh chmod -fileid +w $fh close $fh GetMode CHMOD.TMP } {666} test chmod-3.15 {chmod symbolic mode tests} {need_fchmod} { chmod 0600 CHMOD.TMP set fh [open CHMOD.TMP w] chmod -fileid 000 $fh chmod -fileid +r $fh chmod -fileid +w $fh chmod -fileid +x $fh close $fh GetMode CHMOD.TMP } {777} test chmod-3.16 {chmod symbolic mode tests} {need_fchmod} { chmod 0600 CHMOD.TMP set fh [open CHMOD.TMP w] chmod -fileid 000 $fh chmod -fileid +r $fh chmod -fileid +w $fh chmod -fileid +x $fh chmod -fileid -r $fh close $fh GetMode CHMOD.TMP } {333} test chmod-3.17 {chmod symbolic mode tests} {need_fchmod} { chmod 0600 CHMOD.TMP set fh [open CHMOD.TMP w] chmod -fileid 000 $fh chmod -fileid +r $fh chmod -fileid +w $fh chmod -fileid +x $fh chmod -fileid -r $fh chmod -fileid -w $fh close $fh GetMode CHMOD.TMP } {111} # +t is dificult to test if not root, just make sure it execute and hope # for the best. Doesn't even work on some systems if [CheckChmod "u+t" "----------" "---------T"] { test chmod-3.14 {chmod symbolic mode tests} { chmod 000 CHMOD.TMP chmod u+x CHMOD.TMP chmod u+t CHMOD.TMP set mode [GetMode CHMOD.TMP] expr "($mode == 100) || ($mode == 1100)" } {1} test chmod-3.14 {chmod symbolic mode tests} { chmod 000 CHMOD.TMP chmod u+x CHMOD.TMP chmod u+t CHMOD.TMP } {} test chmod-3.15 {chmod symbolic mode tests} { chmod 000 CHMOD.TMP chmod u+x CHMOD.TMP chmod u+t CHMOD.TMP chmod u-t CHMOD.TMP } {} } test chmod-3.16 {chmod symbolic mode tests} { chmod 000 CHMOD.TMP chmod a+rwx CHMOD.TMP chmod u-r,g-w,o-x CHMOD.TMP GetMode CHMOD.TMP } {356} test chmod-4.1 {chmod error tests} { list [catch {chmod +z CHMOD.TMP} msg] $msg } {1 {invalid file mode "+z"}} test chmod-4.2 {chmod error tests} { list [catch {chmod} msg] $msg } {1 {wrong # args: chmod [-fileid] mode filelist}} test chmod-4.3 {chmod error tests} {need_fchmod} { list [catch {chmod -fileid +w BAD} msg] $msg } {1 {can not find channel named "BAD"}} test chmod-4.4 {chmod error tests} {need_fchmod} { list [catch {chmod -file -w CHMOD.TMP} msg] $msg } {1 {wrong # args: chmod [-fileid] mode filelist}} # chown and chgrp tests set myUID [id userid] set myGID [id groupid] # # Some machines have problems with changing group ids on files (even to your # own) if you are not root. On some it works for chown but not fchown (Ultix). # SetUpTestFiles set ::tcltest::testConstraints(chownWorks) 1 if {[catch {chown [id userid] CHMOD.TMP} msg ] || [catch {chgrp [id groupid] CHMOD.TMP} msg ]} { puts "********************************************************************" puts "Can't do chown or chgrp even when current and new group id are" puts "ours. You probably have to be root. Some chown/chgrp tests skipped" puts "on this system." puts " $msg" puts "********************************************************************" set ::tcltest::testConstraints(chownWorks) 0 } if [infox have_fchown] { set ::tcltest::testConstraints(fchownWorks) 1 set fh [open CHMOD.TMP w] if {[catch {chown -fileid [id userid] $fh} msg ] || [catch {chgrp -fileid [id groupid] $fh} msg ]} { puts "****************************************************************" puts "Can't do chown or chgrp with -fileid even when current and new" puts "groupid are ours. You probably have to be root. Some chown/chgrp" puts "tests skipped on this system." puts " $msg" puts "****************************************************************" set ::tcltest::testConstraints(fchownWorks) 0 } close $fh } test chmod-5.1 {chown tests} {chownWorks} { SetUpTestFiles chown [id user] {CHMOD.TMP CHMOD2.TMP} list [GetUID CHMOD.TMP] [GetUID CHMOD2.TMP] } [list $myUID $myUID] test chmod-5.2 {chown tests} {chownWorks} { chown [id userid] {CHMOD.TMP CHMOD2.TMP} list [GetUID CHMOD.TMP] [GetUID CHMOD2.TMP] } [list $myUID $myUID] test chmod-5.3 {chown tests} {chownWorks} { chown [list [id userid] [id groupid]] {CHMOD.TMP CHMOD2.TMP} list [GetUIDGID CHMOD.TMP] [GetUIDGID CHMOD2.TMP] } [list [list $myUID $myGID] [list $myUID $myGID]] test chmod-5.4 {chown tests} {chownWorks} { chown [list [id user] [id group]] {CHMOD.TMP CHMOD2.TMP} list [GetUIDGID CHMOD.TMP] [GetUIDGID CHMOD2.TMP] } [list [list $myUID $myGID] [list $myUID $myGID]] test chmod-5.5 {chown tests} {chownWorks} { chown [list [id user] [id group]] {CHMOD.TMP CHMOD2.TMP} list [GetUIDGID CHMOD.TMP] [GetUIDGID CHMOD2.TMP] } [list [list $myUID $myGID] [list $myUID $myGID]] test chmod-5.6 {chown tests} {need_fchown && fchownWorks} { SetUpTestFiles set fh1 [open CHMOD.TMP w] set fh2 [open CHMOD2.TMP w] chown -fileid [id user] [list $fh1 $fh2] close $fh1 close $fh2 list [GetUID CHMOD.TMP] [GetUID CHMOD2.TMP] } [list $myUID $myUID] test chmod-5.7 {chown tests} {need_fchown && fchownWorks} { set fh1 [open CHMOD.TMP w] set fh2 [open CHMOD2.TMP w] chown -fileid [id userid] [list $fh1 $fh2] close $fh1 close $fh2 list [GetUID CHMOD.TMP] [GetUID CHMOD2.TMP] } [list $myUID $myUID] test chmod-5.8 {chown tests} {need_fchown && fchownWorks} { set fh1 [open CHMOD.TMP w] set fh2 [open CHMOD2.TMP w] chown -fileid [list [id userid] [id groupid]] [list $fh1 $fh2] close $fh1 close $fh2 list [GetUIDGID CHMOD.TMP] [GetUIDGID CHMOD2.TMP] } [list [list $myUID $myGID] [list $myUID $myGID]] test chmod-5.9 {chown tests} {need_fchown && fchownWorks} { set fh1 [open CHMOD.TMP w] set fh2 [open CHMOD2.TMP w] chown -fileid [list [id user] [id group]] [list $fh1 $fh2] close $fh1 close $fh2 list [GetUIDGID CHMOD.TMP] [GetUIDGID CHMOD2.TMP] } [list [list $myUID $myGID] [list $myUID $myGID]] test chmod-5.10 {chown tests} {need_fchown && fchownWorks} { set fh1 [open CHMOD.TMP w] set fh2 [open CHMOD2.TMP w] chown -fileid [list [id user] [id group]] [list $fh1 $fh2] close $fh1 close $fh2 list [GetUIDGID CHMOD.TMP] [GetUIDGID CHMOD2.TMP] } [list [list $myUID $myGID] [list $myUID $myGID]] SetUpTestFiles test chmod-6.1 {chown error tests} { list [catch {chown XXXXXXXXX CHMOD.TMP} msg] $msg } {1 {unknown user id: XXXXXXXXX}} test chmod-6.2 {chown error tests} { list [catch {chown [list XXXXXXXXX [id groupid]] CHMOD.TMP} msg] $msg } {1 {unknown user id: XXXXXXXXX}} test chmod-6.3 {chown error tests} { list [catch {chown [list [id user] XXXXXXXXX] CHMOD.TMP} msg] $msg } {1 {unknown group id: XXXXXXXXX}} test chmod-6.4 {chown error tests} { list [catch {chown {XXXXXXXXX YYYY} CHMOD.TMP} msg] $msg } {1 {unknown user id: XXXXXXXXX}} test chmod-6.5 {chown error tests} { list [catch {chown} msg] $msg } {1 {wrong # args: chown [-fileid] user|{user group} filelist}} test chmod-6.6 {chown error tests} {need_fchown} { list [catch {chown -fileid $myUID BAD} msg] $msg } {1 {can not find channel named "BAD"}} test chmod-6.6 {chown error tests} {need_fchown} { list [catch {chown -fid $myUID CHMOD.TMP} msg] $msg } {1 {Invalid option "-fid", expected "-fileid"}} test chmod-7.1 {chgrp tests} {chownWorks} { chgrp [id group] {CHMOD.TMP CHMOD2.TMP} list [GetGID CHMOD.TMP] [GetGID CHMOD2.TMP] } [list $myGID $myGID] test chmod-7.2 {chgrp tests} {chownWorks} { chgrp [id groupid] {CHMOD.TMP CHMOD2.TMP} list [GetGID CHMOD.TMP] [GetGID CHMOD2.TMP] } [list $myGID $myGID] test chmod-7.3 {chgrp tests} {need_fchown && fchownWorks} { set fh1 [open CHMOD.TMP w] set fh2 [open CHMOD2.TMP w] chgrp -fileid [id group] [list $fh1 $fh2] close $fh1 close $fh2 list [GetGID CHMOD.TMP] [GetGID CHMOD2.TMP] } [list $myGID $myGID] test chmod-7.4 {chgrp tests} {need_fchown && fchownWorks} { set fh1 [open CHMOD.TMP w] set fh2 [open CHMOD2.TMP w] chgrp -fileid [id groupid] [list $fh1 $fh2] close $fh1 close $fh2 list [GetGID CHMOD.TMP] [GetGID CHMOD2.TMP] } [list $myGID $myGID] test chmod-8.1 {chgrp error tests} { list [catch {chgrp} msg] $msg } {1 {wrong # args: chgrp [-fileid] group filelist}} test chmod-8.2 {chgrp error tests} { list [catch {chgrp XXXXXXXXX CHMOD.TMP} msg] $msg } {1 {unknown group id: XXXXXXXXX}} test chmod-8.3 {chown error tests} {need_fchown} { list [catch {chgrp -fileid $myGID BAD} msg] $msg } {1 {can not find channel named "BAD"}} test chmod-8.4 {chown error tests} {need_fchown} { list [catch {chgrp -fid $myGID CHMOD.TMP} msg] $msg } {1 {Invalid option "-fid", expected "-fileid"}} TestRemove CHECK.TMP CHMOD.TMP CHMOD2.TMP # cleanup ::tcltest::cleanupTests return tclx8.4-8.4.1.orig/tests/showproc.test0000644000000000000000000000300212046313167014462 0ustar # # showproc.test # # Tests for tcl.tlib showproc routines. #--------------------------------------------------------------------------- # Copyright 1992-1999 Karl Lehenbauer and Mark Diekhans. # # Permission to use, copy, modify, and distribute this software and its # documentation for any purpose and without fee is hereby granted, provided # that the above copyright notice appear in all copies. Karl Lehenbauer and # Mark Diekhans make no representations about the suitability of this # software for any purpose. It is provided "as is" without express or # implied warranty. #------------------------------------------------------------------------------ # $Id: showproc.test,v 1.2 2002/04/02 02:29:43 hobbs Exp $ #------------------------------------------------------------------------------ # if {[cequal [info procs Test] {}]} { source [file join [file dirname [info script]] testlib.tcl] } set testProcVar {proc testproc testVar { return 1 }} eval $testProcVar set testProcVar2 {proc testproc2 {testVar {baz 10}} { return 60 }} eval $testProcVar2 Test showproc-1.1 {showproc command} { showproc testproc } 0 "$testProcVar\n" Test showproc-1.2 {showproc command} { showproc testproc testproc2 } 0 "$testProcVar\n$testProcVar2\n" Test showproc-1.3 {showproc command} { set result "" foreach line [split [showproc] "\n"] { if [regexp {^proc ([^ ]+) } $line {} pname] { lappend result $pname } } lsort $result } 0 [lsort [info procs]] # cleanup ::tcltest::cleanupTests return tclx8.4-8.4.1.orig/tests/signal.test0000644000000000000000000002371712046313166014111 0ustar # # signal.test # # Tests for the signal and kill commands. #--------------------------------------------------------------------------- # Copyright 1992-1999 Karl Lehenbauer and Mark Diekhans. # # Permission to use, copy, modify, and distribute this software and its # documentation for any purpose and without fee is hereby granted, provided # that the above copyright notice appear in all copies. Karl Lehenbauer and # Mark Diekhans make no representations about the suitability of this # software for any purpose. It is provided "as is" without express or # implied warranty. #------------------------------------------------------------------------------ # $Id: signal.test,v 1.3 2002/04/03 02:44:21 hobbs Exp $ #------------------------------------------------------------------------------ # if {[cequal [info procs Test] {}]} { source [file join [file dirname [info script]] testlib.tcl] } if [cequal $tcl_platform(platform) windows] { echo " * The signal tests have not been ported to Win32" return } # # Fork without exec will not work under Tk, skip this test # if ![lempty [info commands button]] { puts "*************************************************************" puts "Signal tests are constructed in a way that does not work" puts "under Tk. Test skipped." puts "*************************************************************" puts "" return } Test signal-1.1 {signal tests} { signal ignore SIGHUP kill HUP [id process] } 0 {} Test signal-1.2 {signal tests} { global errorInfo set errorInfo {} signal error HUP proc KillMe3 {} {kill SIGHUP [id process]} proc KillMe2 {} {KillMe3} proc KillMe1 {} {KillMe2} list [catch {KillMe1} msg] $msg $errorInfo } 0 {1 {SIGHUP signal received} {SIGHUP signal received while executing "kill SIGHUP [id process]" (procedure "KillMe3" line 1) invoked from within "KillMe3" (procedure "KillMe2" line 1) invoked from within "KillMe2" (procedure "KillMe1" line 1) invoked from within "KillMe1"}} Test signal-1.3 {signal tests} { signal error {HUP SIGTERM} set one [list [catch {kill HUP [id process]} msg] $msg] set two [list [catch {kill TERM [id process]} msg] $msg] list $one $two } 0 {{1 {SIGHUP signal received}} {1 {SIGTERM signal received}}} Test signal-1.4 {signal tests} { set signalWeGot {} signal trap 1 {set signalWeGot %S} kill SIGHUP [id process] signal default 1 set signalWeGot } 0 {SIGHUP} Test signal-1.41 {signal tests} { set signalWeGot {} set signalTrash {} signal trap 1 {set signalWeGot %S; set signalTrash "%%"} kill SIGHUP [id process] signal default 1 list $signalWeGot $signalTrash } 0 {SIGHUP %%} Test signal-1.42 {signal tests} { signal trap 1 {set signalWeGot %s; set signalTrash "%%"} kill SIGHUP [id process] } 1 {bad signal trap command formatting specification "%s", expected one of "%%" or "%S"} signal default SIGHUP Test signal-1.5 {signal tests} { signal default {SIGHUP SIGINT} signal get {SIGHUP SIGINT} } 0 {{SIGHUP {default 0 {} 0}} {SIGINT {default 0 {} 0}}} Test signal-1.6 {signal tests} { signal default SIGHUP signal ignore SIGINT signal get {SIGHUP SIGINT} } 0 {{SIGHUP {default 0 {} 0}} {SIGINT {ignore 0 {} 0}}} Test signal-1.7 {signal tests} { signal trap {SIGHUP SIGINT} {error "Should not get this signal"} signal get {SIGHUP SIGINT} } 0 [list {SIGHUP {trap 0 {error "Should not get this signal"} 0}} \ {SIGINT {trap 0 {error "Should not get this signal"} 0}} ] Test signal-1.8 {signal tests} { signal error {SIGHUP SIGINT} signal get {SIGHUP SIGINT} } 0 {{SIGHUP {error 0 {} 0}} {SIGINT {error 0 {} 0}}} Test signal-1.8.1 {signal tests} { signal error {SIGHUP SIGINT} set sigkl [signal get *] list [keylget sigkl SIGHUP] [keylget sigkl SIGINT] } 0 {{error 0 {} 0} {error 0 {} 0}} Test signal-1.8.2 {signal tests} { set sigkl [signal get *] list [keylget sigkl SIGALRM {}] [keylget sigkl SIGPIPE {}] \ [keylget sigkl SIGINT {}] } 0 {1 1 1} Test signal-1.8.3 {signal tests} { signal error {SIGHUP SIGINT} set sigkl [signal get *] signal default {SIGHUP SIGINT} signal set $sigkl signal get {SIGHUP SIGINT} } 0 {{SIGHUP {error 0 {} 0}} {SIGINT {error 0 {} 0}}} if [infox have_signal_restart] { Test signal-1.8.4 {signal tests} { signal -restart error {SIGHUP SIGINT} signal get {SIGHUP SIGINT} } 0 {{SIGHUP {error 0 {} 1}} {SIGINT {error 0 {} 1}}} } Test signal-1.9 {signal tests} { global errorInfo set errorInfo {} proc KillMe3 {} {kill SIGHUP [id process]} proc KillMe2 {} {KillMe3} proc KillMe1 {} {KillMe2} signal trap SIGHUP {error "Blew it in the trap code"} list [catch {KillMe1} msg ] $msg $errorInfo } 0 {1 {Blew it in the trap code} {Blew it in the trap code while executing "error "Blew it in the trap code"" while executing signal trap code for SIGHUP signal invoked from within "kill SIGHUP [id process]" (procedure "KillMe3" line 1) invoked from within "KillMe3" (procedure "KillMe2" line 1) invoked from within "KillMe2" (procedure "KillMe1" line 1) invoked from within "KillMe1"}} Test signal-1.10 {signal tests} { signal } 1 {wrong # args: signal ?-restart? action signalList ?command?} Test signal-1.11 {signal tests} { signal ignore foo } 1 {invalid signal "foo"} Test signal-1.12 {signal tests} { signal ignore sigint "echo foo" } 1 {command may not be specified for "ignore" action} Test signal-1.13 {signal tests} { signal baz sigint } 1 {invalid signal action specified: baz: expected one of "default", "ignore", "error", "trap", "get", "set", "block", or "unblock"} # # Complex test for the death of a child. # proc PollSigChld {} { global G_gotChild set sleepCnt 0 while {!$G_gotChild} { incr sleepCnt if {$sleepCnt > 90} { error "signal-1.14: SIGCHLD lost" } sleep 1 } } proc ForkChild {exitCode} { flush stdout ;# Not going to exec, must clean up the buffers. flush stderr set childPid [fork] if {$childPid == 0} { exit $exitCode } return $childPid } if [infox have_posix_signals] { set expect {123 {{SIGCHLD {trap 0 {global G_gotChild;set G_gotChild 1;sleep 1} 0}}}} } else { set expect {123 {{SIGCHLD {default 0 {} 0}}}} } set expect Test signal-1.15 {signal tests} { global G_gotChild set G_gotChild 0 signal trap SIGCHLD {global G_gotChild;set G_gotChild 1;sleep 1} set pid1 [ForkChild 123] PollSigChld set status1 [wait $pid1] list [lindex $status1 2] [signal get SIGCHLD] } 0 $expect signal default SIGCHLD # # Check that the signals are left in the correct state after receiving # a signal (on SIGCHLD is different if we have Posix signals). # Test signal-1.16 {signal tests} { global G_gotChild set G_gotChild 0 signal trap SIGCHLD {global G_gotChild;set G_gotChild 1} kill SIGCHLD [id process] set gotChild1 $G_gotChild set G_gotChild 0 kill SIGCHLD [id process] set gotChild2 $G_gotChild set G_gotChild 0 signal trap SIGCHLD {global G_gotChild;set G_gotChild 1} kill SIGCHLD [id process] set gotChild3 $G_gotChild signal default SIGCHLD list $gotChild1 $gotChild2 $gotChild3 } 0 [list 1 [infox have_posix_signals] 1] Test signal-1.17 {signal tests} { global G_gotPipe set G_gotPipe 0 signal trap SIGPIPE {global G_gotPipe;set G_gotPipe 1} kill SIGPIPE [id process] set gotPipe1 $G_gotPipe set G_gotPipe 0 kill SIGPIPE [id process] set gotPipe2 $G_gotPipe signal default SIGPIPE list $gotPipe1 $gotPipe2 } 0 {1 1} if [infox have_posix_signals] { Test signal-1.18 {signal tests} { signal error SIGHUP signal block SIGHUP signal get SIGHUP } 0 {{SIGHUP {error 1 {} 0}}} Test signal-1.19 {signal tests} { signal unblock SIGHUP signal get SIGHUP } 0 {{SIGHUP {error 0 {} 0}}} Test signal-1.18 {signal tests} { signal block SIGHUP signal error SIGHUP signal get SIGHUP } 0 {{SIGHUP {error 1 {} 0}}} signal unblock SIGHUP signal default SIGHUP } Test signal-2.1 {kill tests} { kill } 1 {wrong # args: kill ?-pgroup? ?signal? idlist} signal error SIGINT Test signal-2.2 {kill tests} { kill 2 [id process] } 1 {SIGINT signal received} Test signal-2.3 {kill tests} { kill INT [id process] } 1 {SIGINT signal received} Test signal-2.4 {kill tests} { kill SIGINT [id process] } 1 {SIGINT signal received} Test signal-2.5 {kill tests} { kill 10000 [id process] } 1 {invalid signal "10000"} Test signal-2.6 {kill tests} { kill SIGFOO [id process] } 1 {invalid signal "SIGFOO"} test signal-2.7 {kill tests} { kill 0 [id process] } {} if [infox have_posix_signals] { test signal-2.8 {kill tests} { set pgrp [ForkLoopingChild 1] kill -pgroup SIGKILL $pgrp lrange [wait -pgroup $pgrp] 1 2 } {SIG SIGKILL} } # Check -restart if ![infox have_signal_restart] { echo Notice: restarting of interrupted system calls is not available on this system. } else { test signal-3.0 {kill tests} { # Start program on a pipe, but don't doing anything until we send it # something to make timing issues smaller. set fh [open sigprog.tmp w] puts $fh "gets stdin; after 5000; update; puts HELLO; flush stdout" close $fh set sp [open "|[list $::tcltest::tcltest sigprog.tmp]" r+] try_eval { set resp BYE fconfigure $sp -buffering none set gotAlarm 0 signal -restart trap SIGALRM {set ::gotAlarm 1} alarm 1 puts $sp "GO" set resp [gets $sp] } {} { catch {close $sp} alarm 0 } list $resp $gotAlarm # Note this this is somewhat timing dependent and might fail # on a heavly loaded system. } {HELLO 1} } file delete sigprog.tmp # cleanup ::tcltest::cleanupTests return tclx8.4-8.4.1.orig/tests/tryeval.test0000644000000000000000000001514012046313167014312 0ustar # # tryeval.test # # Tests for the try_eval command. #--------------------------------------------------------------------------- # Copyright 1997-1999 Karl Lehenbauer and Mark Diekhans. # # Permission to use, copy, modify, and distribute this software and its # documentation for any purpose and without fee is hereby granted, provided # that the above copyright notice appear in all copies. Karl Lehenbauer and # Mark Diekhans make no representations about the suitability of this # software for any purpose. It is provided "as is" without express or # implied warranty. #------------------------------------------------------------------------------ # $Id: tryeval.test,v 1.3 2002/04/04 06:10:30 hobbs Exp $ #------------------------------------------------------------------------------ # if {[cequal [info procs Test] {}]} { source [file join [file dirname [info script]] testlib.tcl] } # # Use a proc to do some tests to see if errorInfo and errorCode are preserved # and imported correctly. # proc test_try_eval {code catch {finally {}}} { try_eval $code $catch $finally } proc test_try_eval_results {code catch {finally {}}} { set code [catch {test_try_eval $code $catch $finally} result] global errorInfo errorCode return [list $code $result $errorInfo $errorCode] } proc init_error_vars {errorInfoVal errorCodeVal} { global errorInfo errorCode set errorInfo $errorInfoVal set errorCode $errorCodeVal } test try_eval-1.1 {try_eval argument checking} { list [catch {try_eval} msg] $msg } {1 {wrong # args: try_eval code catch ?finally?}} test try_eval-1.2 {try_eval argument checking} { list [catch {try_eval badcommand} msg] $msg } {1 {wrong # args: try_eval code catch ?finally?}} test try_eval-1.3 {try_eval argument checking} { list [catch {try_eval badcommand badcommand2 badcommand3 badcommand4} msg]\ $msg } {1 {wrong # args: try_eval code catch ?finally?}} test try_eval-2.1 {try_eval ok result} { init_error_vars "errorInfo-2.1" "errorCode-2.1" set result [test_try_eval_results { concat "try_eval result 2.1" } { error "error should not execute" } { global final set final "finally-2.1" concat "finally result should not be returned" }] global final concat $result $final } {0 {try_eval result 2.1} errorInfo-2.1 errorCode-2.1 finally-2.1} test try_eval-2.2 {try_eval ok result} { init_error_vars "errorInfo-2.2" "errorCode-2.2" set result [test_try_eval_results { concat "try_eval result 2.2" } { error "error should not execute" } ] list $result } {{0 {try_eval result 2.2} errorInfo-2.2 errorCode-2.2}} test try_eval-2.3 {try_eval ok result} { init_error_vars "errorInfo-2.3" "errorCode-2.3" set result [test_try_eval_results { concat "try_eval result 2.3" } {} { global final set final "finally-2.3" concat "finally result should not be returned" } ] global final concat $result $final } {0 {try_eval result 2.3} errorInfo-2.3 errorCode-2.3 finally-2.3} test try_eval-3.1 {try_eval error result} { init_error_vars "errorInfo-3.1" "errorCode-3.1" set result [test_try_eval_results { error "try_eval error 3.1" errorInfo-error-3.1 errorCode-error-3.1 } { error "cont: $errorResult" "cont: $errorInfo" "cont: $errorCode" } { catch {error bow wow arf} ;# Hose errorInfo/Code global final set final "finally-3.1" concat "finally result should not be returned" } ] global final concat $result $final } {1 {cont: try_eval error 3.1} {cont: errorInfo-error-3.1 invoked from within "try_eval $code $catch $finally" (procedure "test_try_eval" line 2) invoked from within "test_try_eval $code $catch $finally"} {cont: errorCode-error-3.1} finally-3.1} test try_eval-3.2 {try_eval error result} { init_error_vars "errorInfo-3.2" "errorCode-3.2" set result [test_try_eval_results { error "try_eval error 3.2" errorInfo-error-3.2 errorCode-error-3.2 } { error "cont: $errorResult" "cont: $errorInfo" "cont: $errorCode" } ] list $result } {{1 {cont: try_eval error 3.2} {cont: errorInfo-error-3.2 invoked from within "try_eval $code $catch $finally" (procedure "test_try_eval" line 2) invoked from within "test_try_eval $code $catch $finally"} {cont: errorCode-error-3.2}}} test try_eval-3.3 {try_eval error result} { init_error_vars "errorInfo-3.3" "errorCode-3.3" set result [test_try_eval_results { error "try_eval error 3.3" errorInfo-error-3.3 errorCode-error-3.3 } {} { catch {error bow wow arf} ;# Hose errorInfo/Code global final set final "finally-3.3" concat "finally result should not be returned" } ] global final concat $result $final } {1 {try_eval error 3.3} {errorInfo-error-3.3 invoked from within "try_eval $code $catch $finally" (procedure "test_try_eval" line 2) invoked from within "test_try_eval $code $catch $finally"} errorCode-error-3.3 finally-3.3} test try_eval-3.4 {try_eval error result} { init_error_vars "errorInfo-3.4" "errorCode-3.4" set result [test_try_eval_results { error "try_eval error 3.4" errorInfo-error-3.4 errorCode-error-3.4 } {} { catch {error bow wow arf} ;# Hose errorInfo/Code global final set final "finally-3.4" concat "finally result should not be returned" } ] global final list $result $final } {{1 {try_eval error 3.4} {errorInfo-error-3.4 invoked from within "try_eval $code $catch $finally" (procedure "test_try_eval" line 2) invoked from within "test_try_eval $code $catch $finally"} errorCode-error-3.4} finally-3.4} test try_eval-3.5 {try_eval error result} { init_error_vars "errorInfo-3.5" "errorCode-3.5" set result [test_try_eval_results { error "try_eval error 3.5" errorInfo-error-3.5 errorCode-error-3.5 } { concat "Ok now 3.5" } { catch {error bow wow arf} ;# Hose errorInfo/Code global final set final "finally-3.5" concat "finally result should not be returned" } ] global final concat $result $final } {0 {Ok now 3.5} errorInfo-error-3.5 errorCode-error-3.5 finally-3.5} test try_eval-3.6 {try_eval error result} { init_error_vars "errorInfo-3.6" "errorCode-3.6" set result [test_try_eval_results { error "try_eval error 3.6" errorInfo-error-3.6 errorCode-error-3.6 } { concat "Ok now 3.6" } ] list $result } {{0 {Ok now 3.6} errorInfo-error-3.6 errorCode-error-3.6}} # cleanup ::tcltest::cleanupTests return tclx8.4-8.4.1.orig/tests/profile.test0000644000000000000000000006034012046313167014266 0ustar # # profile.test # # Tests for the profile command and profrep procedure. #------------------------------------------------------------------------------ # Copyright 1992-1999 Karl Lehenbauer and Mark Diekhans. # # Permission to use, copy, modify, and distribute this software and its # documentation for any purpose and without fee is hereby granted, provided # that the above copyright notice appear in all copies. Karl Lehenbauer and # Mark Diekhans make no representations about the suitability of this # software for any purpose. It is provided "as is" without express or # implied warranty. #------------------------------------------------------------------------------ # $Id: profile.test,v 1.5 2005/02/04 01:36:13 hobbs Exp $ #------------------------------------------------------------------------------ # if {[cequal [info procs Test] {}]} { source [file join [file dirname [info script]] testlib.tcl] } # Make sure we that real time is not zero. If so, suggest compiling with a # different parameter. However, its always zero on windows proc ProcA1 {} {sleep 1} profile on ProcA1 profile off profData foreach idx [array names profData] { if {[string match "::ProcA1 *" $idx]} break } if {([lindex $profData($idx) 1] == 0) && \ ![cequal $tcl_platform(platform) windows]} { puts "*** The profile command is returning real time values of" puts "*** zero. This suggests that your `times' system call does" puts "*** not return elapsed real time. The configure script" puts "*** did not properly detect this. Try undefining the flag" puts "*** TIMES_RETS_REAL_TIME in unix/Common.mk and reporting" puts "*** this to the maintainers\n" } # # Test error cases. # test profile-1.1 {profile error tests} { list [catch {profile off} msg] $msg } {1 {wrong # args: profile ?-commands? ?-eval? on|off arrayVar}} test profile-1.2 {profile error tests} { list [catch {profile baz} msg] $msg } {1 {expected one of "on" or "off", got "baz"}} test profile-1.3 {profile error tests} { list [catch {profile -comman on} msg] $msg } {1 {expected one of "-commands", or "-eval", got "-comman"}} test profile-1.4 {profile error tests} { list [catch {profile -commands off} msg] $msg } {1 {wrong # args: profile ?-commands? ?-eval? on|off arrayVar}} test profile-1.5 {profile error tests} { list [catch {profile -commands} msg] $msg } {1 {wrong # args: profile ?-commands? ?-eval? on|off arrayVar}} test profile-1.6 {profile error tests} { list [catch {profile -commands on foo} msg] $msg } {1 {wrong # args: profile ?-commands? ?-eval? on|off arrayVar}} test profile-1.7 {profile error tests} { list [catch {profile -commands off foo} msg] $msg } {1 {option "-command" not valid when turning off profiling}} test profile-1.8 {profile error tests} { list [catch {profile -eval off foo} msg] $msg } {1 {option "-eval" not valid when turning off profiling}} test profile-1.9 {profile error tests} { list [catch {profile -commands -eval off foo} msg] $msg } {1 {option "-command" not valid when turning off profiling}} test profile-1.10 {profile error tests} { list [catch {profile off foo} msg] $msg } {1 {profiling is not currently enabled}} test profile-1.11 {profile error tests} { profile on list [catch {profile on} msg] $msg } {1 {profiling is already enabled}} profile off foo # # Filter elements from a procedure call stack so that the "Test" procedure # entry upto but not including the "" entry are dropped from each # record. This allows for consistent results even if the tests are sourced # from a procedure. If the empty list is returned, the stack entry should be # dropped. This eliminates duplicate stack entries. # proc FilterProfStack stack { # If "Test" is at the top, throw this out, or we end up with two # global. if {[cequal [lindex $stack 0] Test] || [regexp {::tcltest::(Eval|RunTest)} [lindex $stack 0]]} { return {} } #puts "PROCESS [info level 0]" # Delete elements Test upto . set newStack {} set foundTest 0 set foundGlobal 0 ;# Used we catch garbage after global foreach elem $stack { #puts -nonewline "PROCESS $elem -> " if {$foundGlobal || [cequal $elem {}]} { set foundGlobal 1 lappend newStack $elem #puts "APPEND IN GLOBAL" } elseif {!$foundTest} { if {[cequal $elem test] || [regexp {::tcltest::(Eval|RunTest)} $elem]} { set foundTest 1 } else { lappend newStack $elem #puts "APPEND IN !FOUND" } } } return $newStack } # # Function to build a list from the profile output data with each entry # contain the call stack and call count. The list is returned sorted by # call stack. Elements from the "Test" procedure entry upto but not including # the "" entry are dropped from each record. This allows for # consistent results even if the tests are sourced from a procedure.x # proc SumCntData {profDataVar} { upvar $profDataVar profData set sumData {} foreach stack [array names profData] { set newStack [FilterProfStack $stack] if {![lempty $newStack]} { lappend sumData [list $newStack [lindex $profData($stack) 0]] } } return [lsort $sumData] } proc listRemovePrecomp {args} { if {$::tcl_version < 8.4} { return $args } # This removes commands that are now compiled, and thus don't # appear in the profile results set res {} foreach arg $args { if {[regexp {^::(list|string|return)$} [lindex $arg 0 0]]} continue lappend res $arg } return $res } # # Test of normal procedure calls. # proc ProcA2 {} {ProcB2; set j 1; incr j; set k 1} proc ProcB2 {} {ProcC2; concat a b; ProcC2; list a b; list c d} proc ProcC2 {} {expr 1+1} test profile-2.1 {profile count tests} { profile on ProcA2 profile off profData SumCntData profData } [list { 1} { 1} \ {{::ProcA2 } 1} \ {{::ProcB2 ::ProcA2 } 1} \ {{::ProcC2 ::ProcB2 ::ProcA2 } 2}] test profile-2.2 {profile count tests} { profile -commands on ProcA2 profile off profData SumCntData profData } [listRemovePrecomp { 1} { 1} \ {{::ProcA2 } 1} \ {{::ProcB2 ::ProcA2 } 1} \ {{::ProcC2 ::ProcB2 ::ProcA2 } 2} \ {{::concat ::ProcB2 ::ProcA2 } 1} \ {{::list ::ProcB2 ::ProcA2 } 2} \ {{::profile } 1}] test profile-2.3 {profile count tests} { profile -eval on ProcA2 profile off profData SumCntData profData } [list { 1} { 1} \ {{::ProcA2 } 1} \ {{::ProcB2 ::ProcA2 } 1} \ {{::ProcC2 ::ProcB2 ::ProcA2 } 2}] test profile-2.4 {profile count tests} { profile -commands -eval on ProcA2 profile off profData SumCntData profData } [listRemovePrecomp { 1} { 1} \ {{::ProcA2 } 1} \ {{::ProcB2 ::ProcA2 } 1} \ {{::ProcC2 ::ProcB2 ::ProcA2 } 2} \ {{::concat ::ProcB2 ::ProcA2 } 1} \ {{::list ::ProcB2 ::ProcA2 } 2} \ {{::profile } 1}] # # Test of uplevel. # proc ProcA3 {} {ProcB3} proc ProcB3 {} {ProcC3} proc ProcC3 {} {uplevel ProcD3; ProcD3} proc ProcD3 {} {set a 1; incr a; concat a b} test profile-3.1 {profile count tests} { profile on ProcA3 profile off profData SumCntData profData } [list { 1} { 1} \ {{::ProcA3 } 1} \ {{::ProcB3 ::ProcA3 } 1} \ {{::ProcC3 ::ProcB3 ::ProcA3 } 1} \ {{::ProcD3 ::ProcB3 ::ProcA3 } 1} \ {{::ProcD3 ::ProcC3 ::ProcB3 ::ProcA3 } 1}] test profile-3.2 {profile count tests} { profile -commands on ProcA3 profile off profData SumCntData profData } [list { 1} { 1} \ {{::ProcA3 } 1} \ {{::ProcB3 ::ProcA3 } 1} \ {{::ProcC3 ::ProcB3 ::ProcA3 } 1} \ {{::ProcD3 ::ProcB3 ::ProcA3 } 1} \ {{::ProcD3 ::ProcC3 ::ProcB3 ::ProcA3 } 1} \ {{::concat ::ProcD3 ::ProcB3 ::ProcA3 } 1} \ {{::concat ::ProcD3 ::ProcC3 ::ProcB3 ::ProcA3 } 1} \ {{::profile } 1} \ {{::uplevel ::ProcC3 ::ProcB3 ::ProcA3 } 1}] test profile-3.3 {profile count tests} { profile -eval on ::ProcA3 profile off profData SumCntData profData } [list { 1} { 1} \ {{::ProcA3 } 1} \ {{::ProcB3 ::ProcA3 } 1} \ {{::ProcC3 ::ProcB3 ::ProcA3 } 1} \ {{::ProcD3 ::ProcC3 ::ProcB3 ::ProcA3 } 2}] test profile-3.4 {profile count tests} { profile -eval -commands on ProcA3 profile off profData SumCntData profData } [list { 1} { 1} \ {{::ProcA3 } 1} \ {{::ProcB3 ::ProcA3 } 1} \ {{::ProcC3 ::ProcB3 ::ProcA3 } 1} \ {{::ProcD3 ::ProcC3 ::ProcB3 ::ProcA3 } 1} \ {{::ProcD3 ::uplevel ::ProcC3 ::ProcB3 ::ProcA3 } 1} \ {{::concat ::ProcD3 ::ProcC3 ::ProcB3 ::ProcA3 } 1} \ {{::concat ::ProcD3 ::uplevel ::ProcC3 ::ProcB3 ::ProcA3 } 1} \ {{::profile } 1} \ {{::uplevel ::ProcC3 ::ProcB3 ::ProcA3 } 1}] # # Test of error unwind. # proc ProcA4 {} {ProcB4} proc ProcB4 {} {catch {ProcC4}; ProcE4} proc ProcC4 {} {ProcD4} proc ProcD4 {} {error baz} proc ProcE4 {} {} test profile-4.1 {profile count tests} { profile on ProcA4 profile off profData SumCntData profData } [list { 1} { 1} \ {{::ProcA4 } 1} \ {{::ProcB4 ::ProcA4 } 1} \ {{::ProcC4 ::ProcB4 ::ProcA4 } 1} \ {{::ProcD4 ::ProcC4 ::ProcB4 ::ProcA4 } 1} \ {{::ProcE4 ::ProcB4 ::ProcA4 } 1}] test profile-4.2 {profile count tests} { profile -commands on ProcA4 profile off profData SumCntData profData } [list { 1} { 1} \ {{::ProcA4 } 1} \ {{::ProcB4 ::ProcA4 } 1} \ {{::ProcC4 ::ProcB4 ::ProcA4 } 1} \ {{::ProcD4 ::ProcC4 ::ProcB4 ::ProcA4 } 1} \ {{::ProcE4 ::ProcB4 ::ProcA4 } 1} \ {{::error ::ProcD4 ::ProcC4 ::ProcB4 ::ProcA4 } 1} \ {{::profile } 1}] test profile-4.3 {profile count tests} { profile -eval on ProcA4 profile off profData SumCntData profData } [list { 1} { 1} \ {{::ProcA4 } 1} \ {{::ProcB4 ::ProcA4 } 1} \ {{::ProcC4 ::ProcB4 ::ProcA4 } 1} \ {{::ProcD4 ::ProcC4 ::ProcB4 ::ProcA4 } 1} \ {{::ProcE4 ::ProcB4 ::ProcA4 } 1}] test profile-4.4 {profile count tests} { profile -commands -eval on ProcA4 profile off profData SumCntData profData } [list { 1} { 1} \ {{::ProcA4 } 1} \ {{::ProcB4 ::ProcA4 } 1} \ {{::ProcC4 ::ProcB4 ::ProcA4 } 1} \ {{::ProcD4 ::ProcC4 ::ProcB4 ::ProcA4 } 1} \ {{::ProcE4 ::ProcB4 ::ProcA4 } 1} \ {{::error ::ProcD4 ::ProcC4 ::ProcB4 ::ProcA4 } 1} \ {{::profile } 1}] # # Test of a command that calls procedures from different levels. # set ::tcltest::testConstraints(tclx_test_eval) \ [llength [info commands tclx_test_eval]] proc ProcA5 {} {ProcB5} proc ProcB5 {} {tclx_test_eval 0 ProcC5a #0 ProcC5b 0 ProcC5c 1 ProcC5d } proc ProcC5a {} {ProcD5} proc ProcC5b {} {ProcD5} proc ProcC5c {} {ProcD5} proc ProcC5d {} {ProcD5} proc ProcD5 {} {concat a b; list c d} test profile-5.1 {profile count tests} {tclx_test_eval} { profile on ProcA5 profile off profData SumCntData profData } [list { 1} { 1} \ {{::ProcA5 } 1} \ {{::ProcB5 ::ProcA5 } 1} \ {{::ProcC5a ::ProcB5 ::ProcA5 } 1} \ {{::ProcC5b } 1} \ {{::ProcC5c ::ProcB5 ::ProcA5 } 1} \ {{::ProcC5d ::ProcA5 } 1} \ {{::ProcD5 ::ProcC5a ::ProcB5 ::ProcA5 } 1} \ {{::ProcD5 ::ProcC5b } 1} \ {{::ProcD5 ::ProcC5c ::ProcB5 ::ProcA5 } 1} \ {{::ProcD5 ::ProcC5d ::ProcA5 } 1}] test profile-5.2 {profile count tests} {tclx_test_eval} { profile -commands on ProcA5 profile off profData SumCntData profData } [listRemovePrecomp { 1} { 1} \ {{::ProcA5 } 1} \ {{::ProcB5 ::ProcA5 } 1} \ {{::ProcC5a ::tclx_test_eval ::ProcB5 ::ProcA5 } 1} \ {{::ProcC5b } 1} \ {{::ProcC5c ::tclx_test_eval ::ProcB5 ::ProcA5 } 1} \ {{::ProcC5d ::ProcA5 } 1} \ {{::ProcD5 ::ProcC5a ::tclx_test_eval ::ProcB5 ::ProcA5 } 1} \ {{::ProcD5 ::ProcC5b } 1} \ {{::ProcD5 ::ProcC5c ::tclx_test_eval ::ProcB5 ::ProcA5 } 1} \ {{::ProcD5 ::ProcC5d ::ProcA5 } 1} \ {{::concat ::ProcD5 ::ProcC5a ::tclx_test_eval ::ProcB5 ::ProcA5 } 1} \ {{::concat ::ProcD5 ::ProcC5b } 1} \ {{::concat ::ProcD5 ::ProcC5c ::tclx_test_eval ::ProcB5 ::ProcA5 } 1} \ {{::concat ::ProcD5 ::ProcC5d ::ProcA5 } 1} \ {{::list ::ProcD5 ::ProcC5a ::tclx_test_eval ::ProcB5 ::ProcA5 } 1} \ {{::list ::ProcD5 ::ProcC5b } 1} \ {{::list ::ProcD5 ::ProcC5c ::tclx_test_eval ::ProcB5 ::ProcA5 } 1} \ {{::list ::ProcD5 ::ProcC5d ::ProcA5 } 1} \ {{::profile } 1} \ {{::tclx_test_eval ::ProcB5 ::ProcA5 } 1}] test profile-5.3 {profile count tests} {tclx_test_eval} { profile -eval on ProcA5 profile off profData SumCntData profData } [list { 1} { 1} \ {{::ProcA5 } 1} \ {{::ProcB5 ::ProcA5 } 1} \ {{::ProcC5a ::ProcB5 ::ProcA5 } 1} \ {{::ProcC5b ::ProcB5 ::ProcA5 } 1} \ {{::ProcC5c ::ProcB5 ::ProcA5 } 1} \ {{::ProcC5d ::ProcB5 ::ProcA5 } 1} \ {{::ProcD5 ::ProcC5a ::ProcB5 ::ProcA5 } 1} \ {{::ProcD5 ::ProcC5b ::ProcB5 ::ProcA5 } 1} \ {{::ProcD5 ::ProcC5c ::ProcB5 ::ProcA5 } 1} \ {{::ProcD5 ::ProcC5d ::ProcB5 ::ProcA5 } 1}] test profile-5.4 {profile count tests} {tclx_test_eval} { profile -eval -commands on ::ProcA5 profile off profData SumCntData profData } [listRemovePrecomp { 1} { 1} \ {{::ProcA5 } 1} \ {{::ProcB5 ::ProcA5 } 1} \ {{::ProcC5a ::tclx_test_eval ::ProcB5 ::ProcA5 } 1} \ {{::ProcC5b ::tclx_test_eval ::ProcB5 ::ProcA5 } 1} \ {{::ProcC5c ::tclx_test_eval ::ProcB5 ::ProcA5 } 1} \ {{::ProcC5d ::tclx_test_eval ::ProcB5 ::ProcA5 } 1} \ {{::ProcD5 ::ProcC5a ::tclx_test_eval ::ProcB5 ::ProcA5 } 1} \ {{::ProcD5 ::ProcC5b ::tclx_test_eval ::ProcB5 ::ProcA5 } 1} \ {{::ProcD5 ::ProcC5c ::tclx_test_eval ::ProcB5 ::ProcA5 } 1} \ {{::ProcD5 ::ProcC5d ::tclx_test_eval ::ProcB5 ::ProcA5 } 1} \ {{::concat ::ProcD5 ::ProcC5a ::tclx_test_eval ::ProcB5 ::ProcA5 } 1} \ {{::concat ::ProcD5 ::ProcC5b ::tclx_test_eval ::ProcB5 ::ProcA5 } 1} \ {{::concat ::ProcD5 ::ProcC5c ::tclx_test_eval ::ProcB5 ::ProcA5 } 1} \ {{::concat ::ProcD5 ::ProcC5d ::tclx_test_eval ::ProcB5 ::ProcA5 } 1} \ {{::list ::ProcD5 ::ProcC5a ::tclx_test_eval ::ProcB5 ::ProcA5 } 1} \ {{::list ::ProcD5 ::ProcC5b ::tclx_test_eval ::ProcB5 ::ProcA5 } 1} \ {{::list ::ProcD5 ::ProcC5c ::tclx_test_eval ::ProcB5 ::ProcA5 } 1} \ {{::list ::ProcD5 ::ProcC5d ::tclx_test_eval ::ProcB5 ::ProcA5 } 1} \ {{::profile } 1} \ {{::tclx_test_eval ::ProcB5 ::ProcA5 } 1}] # # Test evaling from other commands. # proc ProcA6 {} { if {[string compare "y" "x"]} { set foo [ProcB6] set bar [ProcC6] } } proc ProcB6 {} { set t 0 for {set i 1} {$i < 1000} {incr i} { incr t $i } return $t } proc ProcC6 {} { set t 0 for {set i 1} {$i < 2000} {incr i} { incr t $i } return $t } test profile-6.1 {profile count tests} { profile on ProcA6 profile off profData SumCntData profData } [list { 1} { 1} \ {{::ProcA6 } 1} \ {{::ProcB6 ::ProcA6 } 1} \ {{::ProcC6 ::ProcA6 } 1}] test profile-6.2 {profile count tests} { profile -commands on ProcA6 profile off profData SumCntData profData } [listRemovePrecomp { 1} { 1} \ {{::ProcA6 } 1} \ {{::ProcB6 ::ProcA6 } 1} \ {{::ProcC6 ::ProcA6 } 1} \ {{::profile } 1} \ {{::return ::ProcB6 ::ProcA6 } 1} \ {{::return ::ProcC6 ::ProcA6 } 1} \ {{::string ::ProcA6 } 1}] test profile-6.3 {profile count tests} { profile -eval on ProcA6 profile off profData SumCntData profData } [list { 1} { 1} \ {{::ProcA6 } 1} \ {{::ProcB6 ::ProcA6 } 1} \ {{::ProcC6 ::ProcA6 } 1}] test profile-6.4 {profile count tests} { profile -eval -commands on ProcA6 profile off profData SumCntData profData } [listRemovePrecomp { 1} { 1} \ {{::ProcA6 } 1} \ {{::ProcB6 ::ProcA6 } 1} \ {{::ProcC6 ::ProcA6 } 1} \ {{::profile } 1} \ {{::return ::ProcB6 ::ProcA6 } 1} \ {{::return ::ProcC6 ::ProcA6 } 1} \ {{::string ::ProcA6 } 1}] # # Function to build a list from the profile output data with each entry # contain the call stack and call count. The list is returned sorted by # CPU time. CPU time is not included in the return, since it can't be # verified exactly, only approximately. CPU time testing is not done # for Windows as there is no way to determine it. # proc SumCpuData {profDataVar} { upvar $profDataVar profData set sumData {} foreach stack [array names profData] { set newStack [FilterProfStack $stack] if {![lempty $newStack]} { lappend sumData [list [format %032d [lindex $profData($stack) 2]] \ $newStack [lindex $profData($stack) 0]] } } set retData {} foreach entry $sumData { lappend retData [lrange $entry 1 end] } return [lsort $retData] } proc EatTime {amount} { set start [lindex [times] 0] set end [expr $start+$amount] set cnt 0 while {[lindex [times] 0] < $end} { format %d 100 ;# kind of slow command. incr cnt if {($cnt > 10000) && ([lindex [times] 0] == $start)} { error "User CPU time does not appear to be accumulating" } } } proc ProcA10 {} {ProcB10;ProcC10;ProcD10} proc ProcB10 {} {EatTime 1} proc ProcC10 {} {EatTime 100} proc ProcD10 {} {uplevel EatTime 1000} test profile-10.1 {profile CPU time tests} {unixOnly} { profile on ProcA10 profile off profData SumCpuData profData } [list { 1} { 1} \ {{::EatTime ::ProcA10 } 1} \ {{::EatTime ::ProcB10 ::ProcA10 } 1} \ {{::EatTime ::ProcC10 ::ProcA10 } 1} \ {{::ProcA10 } 1} \ {{::ProcB10 ::ProcA10 } 1} \ {{::ProcC10 ::ProcA10 } 1} \ {{::ProcD10 ::ProcA10 } 1}] test profile-10.2 {profile CPU time tests} {unixOnly} { profile -eval on ::ProcA10 profile off profData SumCpuData profData } [list { 1} { 1} \ {{::EatTime ::ProcB10 ::ProcA10 } 1} \ {{::EatTime ::ProcC10 ::ProcA10 } 1} \ {{::EatTime ::ProcD10 ::ProcA10 } 1} \ {{::ProcA10 } 1} {{::ProcB10 ::ProcA10 } 1} \ {{::ProcC10 ::ProcA10 } 1} \ {{::ProcD10 ::ProcA10 } 1}] proc ProcA1 {} {ProcB1;set a 1;incr a} proc ProcB1 {} {ProcC1;ProcC1} proc ProcC1 {} {set a 1;incr a} # # Set up some dummy profile data for the report tests. The data is not # realistic, but designed so that no two numbers that are sorted on are the # same. # catch {unset profData} set baz {::EatTime ::ProcB10 ::ProcA10} set profData($baz) {4 800 10} set baz {::ProcC10 ::ProcA10} set profData($baz) {3 1000 101} set baz {::EatTime ::ProcC10 ::ProcA10} set profData($baz) {2 1001 100} set baz {::ProcD10 ::ProcA10} set profData($baz) {1 100 1071} set baz ::ProcA10 set profData($baz) {5 1250 1180} set baz {::EatTime ::ProcD10 ::ProcA10} set profData($baz) {6 1070 1070} set baz {::ProcB10 ::ProcA10} set profData($baz) {7 80 11} # # Read the profile report into memory and purge the file # proc GetProfRep {fileName} { set fh [open $fileName] set data [read $fh] close $fh file delete $fileName return $data } test profile-11.1 {profrep tests} { profrep profData calls prof.tmp "Profile Test 11.1" GetProfRep prof.tmp } {--------------------------------------------------------- Profile Test 11.1 --------------------------------------------------------- Procedure Call Stack Calls Real Time CPU Time --------------------------------------------------------- ProcB10 7 880 21 ProcA10 EatTime 6 1070 1070 ProcD10 ProcA10 ProcA10 5 5301 3543 EatTime 4 800 10 ProcB10 ProcA10 ProcC10 3 2001 201 ProcA10 EatTime 2 1001 100 ProcC10 ProcA10 ProcD10 1 1170 2141 ProcA10 } test profile-11.2 {profrep tests} { profrep profData real prof.tmp "Profile Test 11.2" GetProfRep prof.tmp } {--------------------------------------------------------- Profile Test 11.2 --------------------------------------------------------- Procedure Call Stack Calls Real Time CPU Time --------------------------------------------------------- ProcA10 5 5301 3543 ProcC10 3 2001 201 ProcA10 ProcD10 1 1170 2141 ProcA10 EatTime 6 1070 1070 ProcD10 ProcA10 EatTime 2 1001 100 ProcC10 ProcA10 ProcB10 7 880 21 ProcA10 EatTime 4 800 10 ProcB10 ProcA10 } test profile-11.3 {profrep tests} { profrep profData cpu prof.tmp "Profile Test 11.3" GetProfRep prof.tmp } {--------------------------------------------------------- Profile Test 11.3 --------------------------------------------------------- Procedure Call Stack Calls Real Time CPU Time --------------------------------------------------------- ProcA10 5 5301 3543 ProcD10 1 1170 2141 ProcA10 EatTime 6 1070 1070 ProcD10 ProcA10 ProcC10 3 2001 201 ProcA10 EatTime 2 1001 100 ProcC10 ProcA10 ProcB10 7 880 21 ProcA10 EatTime 4 800 10 ProcB10 ProcA10 } # # Test of namespaces procedure calls. # namespace eval Prof { proc NSProcA2 {} {NSProcB2; set j 1; incr j; set k 1} proc NSProcB2 {} {NSProcC2; concat a b; NSProcC2; list a b; list c d} proc NSProcC2 {} {expr 1+1} } test profile-12.1 {profile namespace tests} { profile on Prof::NSProcA2 profile off profData SumCntData profData } [list { 1} { 1} \ {{::Prof::NSProcA2 } 1} \ {{::Prof::NSProcB2 ::Prof::NSProcA2 } 1} \ {{::Prof::NSProcC2 ::Prof::NSProcB2 ::Prof::NSProcA2 } 2}] test profile-12.2 {profile namespace tests} { profile -commands on Prof::NSProcA2 profile off profData SumCntData profData } [listRemovePrecomp { 1} { 1} \ {{::Prof::NSProcA2 } 1} \ {{::Prof::NSProcB2 ::Prof::NSProcA2 } 1} \ {{::Prof::NSProcC2 ::Prof::NSProcB2 ::Prof::NSProcA2 } 2} \ {{::concat ::Prof::NSProcB2 ::Prof::NSProcA2 } 1} \ {{::list ::Prof::NSProcB2 ::Prof::NSProcA2 } 2} \ {{::profile } 1}] test profile-12.3 {profile namespace tests} { profile -eval on Prof::NSProcA2 profile off profData SumCntData profData } [list { 1} { 1} \ {{::Prof::NSProcA2 } 1} \ {{::Prof::NSProcB2 ::Prof::NSProcA2 } 1} \ {{::Prof::NSProcC2 ::Prof::NSProcB2 ::Prof::NSProcA2 } 2}] test profile-12.4 {profile namespace tests} { profile -commands -eval on Prof::NSProcA2 profile off profData SumCntData profData } [listRemovePrecomp { 1} { 1} \ {{::Prof::NSProcA2 } 1} \ {{::Prof::NSProcB2 ::Prof::NSProcA2 } 1} \ {{::Prof::NSProcC2 ::Prof::NSProcB2 ::Prof::NSProcA2 } 2} \ {{::concat ::Prof::NSProcB2 ::Prof::NSProcA2 } 1} \ {{::list ::Prof::NSProcB2 ::Prof::NSProcA2 } 2} \ {{::profile } 1}] namespace delete Prof unset foo # cleanup ::tcltest::cleanupTests return tclx8.4-8.4.1.orig/tests/nice.test0000644000000000000000000000632112046313167013543 0ustar # # nice.test # # Tests for the nice command. #--------------------------------------------------------------------------- # Copyright 1993-1999 Karl Lehenbauer and Mark Diekhans. # # Permission to use, copy, modify, and distribute this software and its # documentation for any purpose and without fee is hereby granted, provided # that the above copyright notice appear in all copies. Karl Lehenbauer and # Mark Diekhans make no representations about the suitability of this # software for any purpose. It is provided "as is" without express or # implied warranty. #------------------------------------------------------------------------------ # $Id: #------------------------------------------------------------------------------ # if {[cequal [info procs Test] {}]} { source [file join [file dirname [info script]] testlib.tcl] } if [cequal $tcl_platform(platform) windows] { echo " * The nice command has not been ported to Win32" return } # # Fork without exec will not work under Tk, skip this test # if {[info exists tk_version]} { puts "*************************************************************" puts "Nice tests are constructed in a way that does not work" puts "under Tk. Test skipped." puts "*************************************************************" return } # # Right now, we depend on the base priority being zero. # if {[nice] != 0} { puts "*************************************************************" puts "Nice priority is [nice], not zero. May cause some failures." puts "(but everything is probably ok)" puts "*************************************************************" } set niceBase [nice] test nice-1.1 {nice tests} { list [catch {nice 0 1} msg] $msg } {1 {wrong # args: nice ?priorityincr?}} test nice-1.2 {nice tests} { nice 0 } $niceBase # # Since you can't nice back up unless you're root, we spawn a child process # to run the nice tests. # flush stdout flush stderr set pid [fork] # # Parent waits for child to complete. # if {$pid > 0} { wait $pid # cleanup ::tcltest::cleanupTests return } test nice-1.4 {nice tests} { list [nice 3] [nice] } [list [expr $niceBase+3] [expr $niceBase+3]] test nice-1.5 {nice tests} { list [nice 4] [nice] } [list [expr $niceBase+3+4] [expr $niceBase+3+4]] test nice-1.7 {nice tests} {isNotRoot} { set errList {{not owner} {permission denied} {not privileged} {no permission match} {invalid argument}} set stat [catch {nice -1} msg] set msg [string tolower $msg] if {![regexp {^failed to increment priority: (.*)$} $msg {} errmsg] || \ ([lsearch $errList $errmsg] < 0)} { set stat [list $stat $msg] } set stat } 1 test nice-1.8 {nice tests} {isRoot} { list [nice -1] [nice] } [list [expr $niceBase+3+4-1] [expr $niceBase+3+4-1]] test nice-1.10 {nice tests} {isRoot} { list [nice -9] [nice] } [list [expr $niceBase+3+4-1-9] [expr $niceBase+3+4-1-9]] test nice-1.11 {nice tests} {isRoot} { list [nice -10] [nice] } [list [expr $niceBase+3+4-1-9-10] [expr $niceBase+3+4-1-9-10]] test nice-1.12 {nice tests} {isRoot} { list [nice -1] [nice] } [list [expr $niceBase+3+4-1-9-10-1] [expr $niceBase+3+4-1-9-10-1]] # cleanup ::tcltest::cleanupTests exit tclx8.4-8.4.1.orig/tests/math.test0000644000000000000000000000635712046313167013567 0ustar # # math.test # # Tests for the random, min, and commands. #--------------------------------------------------------------------------- # Copyright 1992-1999 Karl Lehenbauer and Mark Diekhans. # # Permission to use, copy, modify, and distribute this software and its # documentation for any purpose and without fee is hereby granted, provided # that the above copyright notice appear in all copies. Karl Lehenbauer and # Mark Diekhans make no representations about the suitability of this # software for any purpose. It is provided "as is" without express or # implied warranty. #------------------------------------------------------------------------------ # $Id: math.test,v 1.2 2002/04/02 02:29:43 hobbs Exp $ #------------------------------------------------------------------------------ # if {[cequal [info procs Test] {}]} { source [file join [file dirname [info script]] testlib.tcl] } random seed 100 for {set i 0} {$i < 100} {set i [expr $i+1]} { Test math-1.1.$i {random tests} { set a [random 10] expr "(($a >= 0) || ($a <= 9))" } 0 1 } Test math-1.2 {random tests} { random } 1 {wrong # args: random limit | seed ?seedval?} Test math-1.3 {random tests} { # Max range varies on some machines, so don't validate that part of # the message. list [catch {random 0} msg] [lrange $msg 0 6] } 0 {1 {range must be > 0 and <=}} Test math-1.4 {random tests} { random seed Foo } 1 {expected integer but got "Foo"} Test math-2.1 {max tests} { max 1 2 4 3 } 0 4 Test math-2.2 {max tests} { max -68 65537.4 2 5 } 0 65537.4 Test math-2.3 {max tests} { max -68.7 2100000000 2 5 } 0 2100000000 Test math-2.4 {max tests} { max -68.7 -2 } 0 -2 Test math-2.4.1 {max tests} { max -68.7 } 0 -68.7 Test math-2.4.2 {max tests} { max -68.7 0x200 010 } 0 0x200 Test math-2.4.3 {max tests} { max 668e7 0x200 010 } 0 668e7 Test math-2.5 {max tests} { max } 1 {wrong # args: max num1 ?..numN?} Test math-2.6 {max tests} { max 1 2 3 foo } 1 {expected floating-point number but got "foo"} Test math-3.1 {min tests} { min 1 2 4 3 } 0 1 Test math-3.2 {min tests} { min -68.8 64000 2 5 } 0 -68.8 Test math-3.3 {min tests} { min -2000000000 2000000000 2 5 } 0 -2000000000 Test math-3.3 {min tests} { min 5 } 0 5 Test math-3.3.1 {min tests} { min 5 0x200 010 } 0 5 Test math-3.3.2 {min tests} { min 5e10 0x200 010 } 0 010 Test math-3.4 {min tests} { min } 1 {wrong # args: min num1 ?..numN?} Test math-3.5 {min tests} { min 1 2 3 foo } 1 {expected floating-point number but got "foo"} Test math-4.1 {max function tests} { expr max(1, 4) } 0 4 Test math-4.2 {max function tests} { format %.1f [expr max(-68, 65537.4)] } 0 65537.4 Test math-4.3 {max function tests} { format %.1f [expr max(-68.7, 210000)] } 0 210000.0 Test math-4.4 {max function tests} { format %.1f [expr max(-68.7, -2)] } 0 -2.0 Test math-5.1 {min function tests} { expr min(1, 4) } 0 1 Test math-5.2 {min function tests} { format %.1f [expr min(-68, 65537.4)] } 0 -68.0 Test math-5.3 {min function tests} { format %.1f [expr min(-68.7, 2100000000)] } 0 -68.7 Test math-5.4 {min function tests} { format %.1f [expr min(-68.7, -2)] } 0 -68.7 # cleanup ::tcltest::cleanupTests return tclx8.4-8.4.1.orig/tests/sync.test0000644000000000000000000000223512046313167013601 0ustar # # sync.test # # Tests for the sync command. #--------------------------------------------------------------------------- # Copyright 1993-1999 Karl Lehenbauer and Mark Diekhans. # # Permission to use, copy, modify, and distribute this software and its # documentation for any purpose and without fee is hereby granted, provided # that the above copyright notice appear in all copies. Karl Lehenbauer and # Mark Diekhans make no representations about the suitability of this # software for any purpose. It is provided "as is" without express or # implied warranty. #------------------------------------------------------------------------------ # $Id: #------------------------------------------------------------------------------ # if {[cequal [info procs Test] {}]} { source [file join [file dirname [info script]] testlib.tcl] } TestRemove SYNC.TMP Test sync-1.1 {sync tests} { sync } 0 {} Test sync-1.2 {sync tests} { sync a b } 1 {wrong # args: sync ?filehandle?} Test sync-1.3 {sync tests} { set fh [open SYNC.TMP w] puts $fh [replicate XXX 1000] sync $fh close $fh } 0 {} TestRemove SYNC.TMP # cleanup ::tcltest::cleanupTests return tclx8.4-8.4.1.orig/tests/bsearch.test0000644000000000000000000000436212046313167014237 0ustar # # bsearch.test # # Tests for the bsearch command. #--------------------------------------------------------------------------- # Copyright 1992-1999 Karl Lehenbauer and Mark Diekhans. # # Permission to use, copy, modify, and distribute this software and its # documentation for any purpose and without fee is hereby granted, provided # that the above copyright notice appear in all copies. Karl Lehenbauer and # Mark Diekhans make no representations about the suitability of this # software for any purpose. It is provided "as is" without express or # implied warranty. #------------------------------------------------------------------------------ # $Id: bsearch.test,v 1.2 2002/04/02 02:29:43 hobbs Exp $ #------------------------------------------------------------------------------ # if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import ::tcltest::* } if {[cequal [info procs Test] {}]} { source [file join [file dirname [info script]] testlib.tcl] } # Create a test file TestRemove BSEARCH.TMP set testFH [open BSEARCH.TMP w] for {set cnt 0} {$cnt < 100} {incr cnt} { puts $testFH [GenRec $cnt] } close $testFH # Test bsearch proc BsearchTestCmp {key line} { set linekey [lindex $line 2] return [string compare $key $linekey] } set testFH [open BSEARCH.TMP r] set toggle 0 for {set cnt 0} {$cnt < 100} {incr cnt} { set key1 [format "Key:%04d" $cnt] set key2 [format "KeyX:%04d" $cnt] if {($cnt % 6) == 0} { set expect [GenRec $cnt] if {$toggle} { test bsearch-1.1.$cnt {bsearch tests} { bsearch $testFH $key1 } $expect test bsearch-1.2.$cnt {bsearch tests} { bsearch $testFH $key2 {} BsearchTestCmp } $expect } else { set rec {} test bsearch-1.3.$cnt {bsearch tests} { list [bsearch $testFH $key1 rec] $rec } [list 1 $expect] set rec {} test bsearch-1.4.$cnt {bsearch tests} { list [bsearch $testFH $key2 rec BsearchTestCmp] $rec } [list 1 $expect] } set toggle [expr !$toggle] } } close $testFH TestRemove BSEARCH.TMP # cleanup ::tcltest::cleanupTests return tclx8.4-8.4.1.orig/tests/stringfil.test0000644000000000000000000000303612046313167014626 0ustar # # stringfil.test # # Tests for tcl.tlib string file I/O functions. #--------------------------------------------------------------------------- # Copyright 1992-1999 Karl Lehenbauer and Mark Diekhans. # # Permission to use, copy, modify, and distribute this software and its # documentation for any purpose and without fee is hereby granted, provided # that the above copyright notice appear in all copies. Karl Lehenbauer and # Mark Diekhans make no representations about the suitability of this # software for any purpose. It is provided "as is" without express or # implied warranty. #------------------------------------------------------------------------------ # $Id: stringfil.test,v 1.2 2002/04/02 02:29:43 hobbs Exp $ #------------------------------------------------------------------------------ # if {[cequal [info procs Test] {}]} { source [file join [file dirname [info script]] testlib.tcl] } set stringfileTestVar {a b c d e f g} TestRemove STRINGFIL.DAT Test stringfile-1.1 {write_file command} { write_file STRINGFIL.DAT $stringfileTestVar } 0 {} Test stringfile-2.1 {read_file command} { read_file STRINGFIL.DAT } 0 "$stringfileTestVar\n" Test stringfile-2.2 {read_file command} { read_file -nonewline STRINGFIL.DAT } 0 $stringfileTestVar Test stringfile-2.3 {read_file command} { read_file STRINGFIL.DAT 3 } 0 [crange $stringfileTestVar 0 2] Test stringfile-2.4 {read_file command} { read_file STRINGFIL.DAT nonewline } 0 $stringfileTestVar TestRemove STRINGFIL.DAT # cleanup ::tcltest::cleanupTests return tclx8.4-8.4.1.orig/tests/fstat.test0000644000000000000000000001226712046313167013754 0ustar # # fstat.test # # Tests for the fstat command. #--------------------------------------------------------------------------- # Copyright 1992-1999 Karl Lehenbauer and Mark Diekhans. # # Permission to use, copy, modify, and distribute this software and its # documentation for any purpose and without fee is hereby granted, provided # that the above copyright notice appear in all copies. Karl Lehenbauer and # Mark Diekhans make no representations about the suitability of this # software for any purpose. It is provided "as is" without express or # implied warranty. #------------------------------------------------------------------------------ # $Id: fstat.test,v 1.3 2002/04/04 06:10:30 hobbs Exp $ #------------------------------------------------------------------------------ # if {[cequal [info procs Test] {}]} { source [file join [file dirname [info script]] testlib.tcl] } TestRemove gorp.file set gorpFH [open gorp.file w] puts $gorpFH "Test string" close $gorpFH if ![cequal $tcl_platform(platform) windows] { ;# WIN32??? chmod 0765 gorp.file } set gorpFH [open gorp.file r+] test fstat-1.1 {array return} { catch {unset stat} fstat $gorpFH stat stat lsort [array names stat] } {atime ctime dev gid ino mode mtime nlink size tty type uid} if [cequal $tcl_platform(platform) windows] { set expect {1 13 0 file 0} } else { set expect {1 12 501 file 0} } test fstat-1.2 {array return} { catch {unset stat} fstat $gorpFH stat stat list $stat(nlink) $stat(size) [expr $stat(mode)&0777] $stat(type) \ $stat(tty) } $expect if [cequal $tcl_platform(platform) windows] { set expect {0 0 13} } else { set expect {1 1 12} } test fstat-1.3 {array return} { catch {unset stat} fstat $gorpFH stat stat list [expr {[file mtime gorp.file] == $stat(mtime)}] \ [expr {[file atime gorp.file] == $stat(atime)}] $stat(size) } $expect test fstat-2.1 {keyed list returns} { catch {unset stat} set stat [fstat $gorpFH] lsort [keylkeys stat] } {atime ctime dev gid ino mode mtime nlink size tty type uid} if [cequal $tcl_platform(platform) windows] { set expect {1 13 0 file} } else { set expect {1 12 501 file} } test fstat-2.2 {keyed list returns} { set stat [fstat $gorpFH] list [keylget stat nlink] [keylget stat size] \ [expr [keylget stat mode ]&0777] [keylget stat type] } $expect if [cequal $tcl_platform(platform) windows] { set expect {0 0 13} ;# Can't get times on open file. } else { set expect {1 1 12} } test fstat-2.3 {keyed list returns} { set stat [fstat $gorpFH] list [expr {[file mtime gorp.file] == [keylget stat mtime]}] \ [expr {[file atime gorp.file] == [keylget stat atime]}] \ [keylget stat size] } $expect test fstat-3.1 {individual item returns} unixOnly { set old [fstat $gorpFH mtime] sleep 2 puts $gorpFH "More text" flush $gorpFH set new [fstat $gorpFH mtime] if {($new > $old) && ($new <= ($old+5))} { concat OK } else { error "Bad mtimes: old = $old, new = $new" } } {OK} test fstat-3.2 {individual item returns} {unixOnly} { # Windows doen't really write to disk till end set oldsize [fstat $gorpFH size] puts $gorpFH "More text" flush $gorpFH expr {[fstat $gorpFH size] - $oldsize} } 8 if [cequal $tcl_platform(platform) windows] { set expect 11 } else { set expect 10 } test fstat-3.3 {individual item returns} { set fh [open fstat.tmp w] set oldsize [fstat $fh size] puts $fh "More text" close $fh set fh [open fstat.tmp] set diff [expr {[fstat $fh size] - $oldsize}] close $fh set diff } $expect test fstat-4.1 {type return} {unixOnly} { set fh [open .] set type [fstat $fh type] close $fh set type } directory test fstat-4.2 {type return} { fstat $gorpFH type } file # # Check to see that the values that are returned are at least numeric where # expected # test fstat-4.3 {type return} { set dataList {} foreach type {dev ino mode nlink uid gid size atime mtime ctime tty type} { set data [fstat $gorpFH $type] if [string match "-*" $data] { set data [csubstr $data 1 end] } lappend dataList [ctype digit $data] } set dataList } {1 1 1 1 1 1 1 1 1 1 1 0} test fstat-5.1 {error handling} { list [catch {fstat} msg] $msg } {1 {wrong # args: fstat fileId ?item?|?stat arrayVar?}} test fstat-5.2 {error handling} { list [catch {fstat foo} msg] $msg } {1 {can not find channel named "foo"}} test fstat-5.3 {error handling} { list [catch {fstat $gorpFH foo} msg] $msg } {1 {Got "foo", expected one of "atime", "ctime", "dev", "gid", "ino", "mode", "mtime", "nlink", "size", "tty", "type", "uid", "remotehost", or "localhost"}} test fstat-5.4 {error handling} { catch {unset foo} list [catch {fstat $gorpFH foo foo} msg] $msg } {1 {expected item name of "stat" when using array name}} test fstat-5.5 {error handling} { catch {unset foo} list [catch {fstat $gorpFH stat foo baz} msg] $msg } {1 {wrong # args: fstat fileId ?item?|?stat arrayVar?}} # FIX: Need localhost/remotehost tests. catch {close $gorpFH} TestRemove gorp.file fstat.tmp # cleanup ::tcltest::cleanupTests return tclx8.4-8.4.1.orig/tests/all.tcl0000644000000000000000000000361612046313167013204 0ustar # all.tcl -- # # This file contains a top-level script to run all of the Tcl # tests. Execute it by invoking "source all.test" when running tcltest # in this directory. # # RCS: @(#) $Id: all.tcl,v 1.2 2002/04/02 02:29:43 hobbs Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import ::tcltest::* } set ::tcltest::testSingleFile false set ::tcltest::testsDirectory [file dir [info script]] # We need to ensure that the testsDirectory is absolute ::tcltest::normalizePath ::tcltest::testsDirectory puts stdout "Tests running in interp: [info nameofexecutable]" puts stdout "Tests running with pwd: [pwd]" puts stdout "Tests running in working dir: $::tcltest::testsDirectory" if {[llength $::tcltest::skip] > 0} { puts stdout "Skipping tests that match: $::tcltest::skip" } if {[llength $::tcltest::match] > 0} { puts stdout "Only running tests that match: $::tcltest::match" } if {[llength $::tcltest::skipFiles] > 0} { puts stdout "Skipping test files that match: $::tcltest::skipFiles" } if {[llength $::tcltest::matchFiles] > 0} { puts stdout "Only sourcing test files that match: $::tcltest::matchFiles" } set timeCmd {clock format [clock seconds]} puts stdout "Tests began at [eval $timeCmd]" package require Tclx 8.4 # source each of the specified tests foreach file [lsort [::tcltest::getMatchingFiles]] { set tail [file tail $file] puts stdout $tail if {[catch {source $file} msg]} { puts stdout $msg } } # cleanup puts stdout "\nTests ended at [eval $timeCmd]" ::tcltest::cleanupTests 1 return if 0 { proc eq {a b} { cequal $a $b } proc eq1 {a b} { string equal $a $b } proc eq2 {a b} { foo $a $b} interp alias {} foo {} string equal set a [string repeat a 50]b set b [string repeat a 50]b set c [string repeat a 50]c eq $a $b eq1 $a $b eq2 $a $b } tclx8.4-8.4.1.orig/tests/filescan.test0000644000000000000000000003334212046313167014414 0ustar # # filescan.test # # Tests for the scancontext and scanfile commands. #--------------------------------------------------------------------------- # Copyright 1992-1999 Karl Lehenbauer and Mark Diekhans. # # Permission to use, copy, modify, and distribute this software and its # documentation for any purpose and without fee is hereby granted, provided # that the above copyright notice appear in all copies. Karl Lehenbauer and # Mark Diekhans make no representations about the suitability of this # software for any purpose. It is provided "as is" without express or # implied warranty. #------------------------------------------------------------------------------ # $Id: filescan.test,v 1.2 2002/04/02 02:29:43 hobbs Exp $ #------------------------------------------------------------------------------ # if {[cequal [info procs Test] {}]} { source [file join [file dirname [info script]] testlib.tcl] } # Increment a name. This takes a name and "adds one" to it, that is advancing # each digit lexically through "0"..."9" -> "A"-"Z" -> "a"..."z". When one # digit wraps, the next one is advanced. Optional arg forces upper case only # if true and start with all upper case or digits. proc IncrName {Name args} { set Upper [expr {([llength $args] == 1) && [lindex $args 0]}] set Last [expr [clength $Name]-1] set Begin [csubstr $Name 0 $Last] set Digit [cindex $Name $Last] set Recurse 0 case $Digit in { {9} {set Digit A} {Z} {if {$Upper} {set Recurse 1} else {set Digit a}} {z} {set Recurse 1} default {set Digit [ctype char [expr [ctype ord $Digit]+1]]} } if {$Recurse} { if {$Last == 0} then { return 0 ;# Wrap around } else { return "[IncrName $Begin]0" } } return "$Begin$Digit" } # Proc to generate record that can be validated. The record has # grows quite large to test the dynamic buffering in the file I/O. proc GenScanRec {key lineNum} { set extra [replicate :@@@@@@@@: $lineNum] return "$key This is a test record ($extra) index is $key" } # Proc to validate a matched record. proc ValMatch {scanInfo id} { global testFH matchInfo Test filescan-${id}.1 {filescan tests} { list line $matchInfo(line) } 0 [list line [GenScanRec [keylget scanInfo key] \ [keylget scanInfo linenum]]] Test filescan-${id}.2 {filescan tests} { list offset $matchInfo(offset) } 0 [list offset [keylget scanInfo offset]] if 0 { Test filescan-${id}.2.1 {filescan tests} { list bytesread $matchInfo(bytesread) } 0 [list bytesread [keylget scanInfo bytesread]] } Test filescan-${id}.3 {filescan tests} { list linenum $matchInfo(linenum) } 0 [list linenum [keylget scanInfo linenum]] Test filescan-${id}.4 {filescan tests} { list handle $matchInfo(handle) } 0 [list handle $testFH] global matchCnt incr matchCnt([keylget scanInfo matchType]) } global matchInfo matchCnt chkMatchCnt testFH foreach i {0 1 2 3 df} { set chkMatchCnt($i) 0 } set scanList {} set maxRec 200 # Build a test file and a list of records to scan for. Each element in the # list will have the following info: # {key fileOffset fileLineNumber matchType} # Also build a file to diff against for the -copyfile option. TestRemove TEST.TMP TEST2.TMP TESTCHK.TMP set testFH [open TEST.TMP w] set testChkFH [open TESTCHK.TMP w] set key FatHeadAAAA set bytesRead 0 for {set cnt 0} {$cnt < $maxRec} {incr cnt} { set rec [GenScanRec $key [expr $cnt+1]] incr bytesRead [expr [clength $rec] + 1] if {($cnt % 10) == 0} { set matchType [random 4] incr chkMatchCnt($matchType) set scanInfo {} keylset scanInfo key $key keylset scanInfo offset [tell $testFH] keylset scanInfo bytesread $bytesRead keylset scanInfo linenum [expr $cnt+1] keylset scanInfo matchType $matchType if {[random 2]} { set scanList [concat $scanList [list $scanInfo]] } else { set scanList [concat [list $scanInfo] $scanList] } } else { incr chkMatchCnt(df) puts $testChkFH $rec } if {$cnt == [expr $maxRec/2]} { set midKey $key } puts $testFH $rec set key [IncrName $key 1] ;# Upper case only } close $testFH close $testChkFH # Build up the scan context. set testCH [scancontext create] foreach scanInfo $scanList { set key [keylget scanInfo key] set matchType [keylget scanInfo matchType] set cmd "global matchInfo; ValMatch [list $scanInfo] 1.1" case $matchType in { {0} {scanmatch -nocase $testCH [string toupper $key] $cmd} {1} {scanmatch $testCH ^$key $cmd} {2} {scanmatch $testCH $key\$ $cmd} {3} {scanmatch $testCH $key $cmd} } } scanmatch $testCH { global matchCnt testFH matchInfo incr matchCnt(df) Test filescan-1.2 {filescan tests} { set matchInfo(handle) } 0 $testFH } proc ValScan id { global matchInfo matchCnt chkMatchCnt testFH Test filescan-${id}.1 {filescan tests} { set matchCnt(0) } 0 [set chkMatchCnt(0)] Test filescan-${id}.2 {filescan tests} { set matchCnt(1) } 0 [set chkMatchCnt(1)] Test filescan-${id}.3 {filescan tests} { set matchCnt(2) } 0 [set chkMatchCnt(2)] Test filescan-${id}.4 {filescan tests} { set matchCnt(3) } 0 [set chkMatchCnt(3)] Test filescan-${id}.5 {filescan tests} { set matchCnt(df) } 0 [set chkMatchCnt(df)] } foreach i {0 1 2 3 df} { set matchCnt($i) 0 } set testFH [open TEST.TMP r] scanfile $testCH $testFH close $testFH ValScan 1.3 foreach i {0 1 2 3 df} { set matchCnt($i) 0 } set testFH [open TEST.TMP r] set test2FH [open TEST2.TMP w] scanfile -copyfile $test2FH $testCH $testFH close $testFH close $test2FH ValScan 1.4 Test filescan-1.5 {filescan tests} { set fh [open TESTCHK.TMP] set TESTCHK [read $fh] close $fh set fh [open TEST2.TMP] set TEST2 [read $fh] close $fh cequal $TESTCHK $TEST2 } 0 1 catch {unset TESTCHK} catch {unset TEST2} scancontext delete $testCH # Test return and continue from within match commands set testFH [open TEST.TMP r] set testCH [scancontext create] seek $testFH 0 global matchCnt set matchCnt(0) 0 scanmatch $testCH $midKey { global matchCnt incr matchCnt(0) continue; } scanmatch $testCH ^$midKey { error "This should not ever get executed 2.1" } scanmatch $testCH [IncrName $midKey] { return "FudPucker" } Test filescan-2.2 {filescan tests} { scanfile $testCH $testFH } 0 "FudPucker" scancontext delete $testCH # Test argument checking and error handling. Test filescan-3.1 {filescan tests} { scancontext foomuch } 1 {invalid argument, expected one of: "create", "delete", or "copyfile"} Test filescan-3.2 {filescan tests} { scanmatch $testCH } 1 {wrong # args: scanmatch ?-nocase? contexthandle ?regexp? command} Test filescan-3.3 {filescan tests} { scanmatch } 1 {wrong # args: scanmatch ?-nocase? contexthandle ?regexp? command} Test filescan-3.4 {filescan tests} { scanfile } 1 {wrong # args: scanfile ?-copyfile filehandle? contexthandle filehandle} Test filescan-3.5 {filescan tests} { set testCH [scancontext create] scanfile $testCH $testFH } 1 {no patterns in current scan context} Test filescan-3.6 {filescan tests} { scancontext copyfile } 1 {wrong # args: scancontext copyfile contexthandle ?filehandle?} Test filescan-3.7 {filescan tests} { scancontext copyfile $testCH x y } 1 {wrong # args: scancontext copyfile contexthandle ?filehandle?} catch {scancontext delete $testCH} close $testFH # # Test subMatch handling. # set testFH [open TEST.TMP w] loop idx 0 10 { puts $testFH "AAx[replicate xx $idx]xBBc[replicate cc $idx]cDD" } close $testFH # Procedure to verify submatches. Works for upper or lower case. proc ChkSubMatch {id matchInfoVar} { upvar $matchInfoVar matchInfo set idx [expr $matchInfo(linenum) - 1] set end0 [expr 3+($idx * 2)] Test filescan-$id.0.$idx {filescan tests} { set matchInfo(submatch0) } 0 "x[replicate xx $idx]x" Test filescan-$id.1.$idx {filescan tests} { set matchInfo(subindex0) } 0 "2 $end0" set start1 [expr $end0+3] set end1 [expr $start1+($idx*2)+1] Test filescan-$id.2.$idx {filescan tests} { set matchInfo(submatch1) } 0 "c[replicate cc $idx]c" Test filescan-$id.3.$idx {filescan tests} { set matchInfo(subindex1) } 0 "$start1 $end1" Test filescan-$id.4.$idx {filescan tests} { list [info exists matchInfo(submatch2)] \ [info exists matchInfo(subindex2)] } 0 {0 0} } set testFH [open TEST.TMP r] set testCH [scancontext create] scanmatch $testCH {A*(x*)B*(c*)DD} { ChkSubMatch 4 matchInfo } scanmatch -nocase $testCH {Aa(x*)B(C*)Dd} { ChkSubMatch 5 matchInfo } scanfile $testCH $testFH scancontext delete $testCH close $testFH # # Test optional match patterns. # set testFH [open TEST.TMP w] puts $testFH {ABCD : efgh 123435} puts $testFH {HIJK : efgh 123435} puts $testFH {ABCD : efgh X123435} puts $testFH {HIJK : efgh X123435} close $testFH set testCH [scancontext create] scanmatch $testCH {([H-Z]+)? : ([a-z]+) (X)?([0-9]+)} { set thisLine {} for {set idx 0} {$idx < 50} {incr idx} { if {!([info exists matchInfo(submatch$idx)] || [info exists matchInfo(subindex$idx)])} continue set this [list $idx] lappend this [info exists matchInfo(submatch$idx)] lappend this [info exists matchInfo(subindex$idx)] if [info exists matchInfo(submatch$idx)] { lappend this $matchInfo(submatch$idx) } if [info exists matchInfo(subindex$idx)] { lappend this $matchInfo(subindex$idx) } lappend thisLine $this } lappend matches $thisLine catch {unset this} unset thisLine } set testFH [open TEST.TMP r] Test filescan-6.1 {filescan tests} { set matches {} scanfile $testCH $testFH set matches } 0 [list \ [list {0 1 1 {} {-1 -1}} \ {1 1 1 efgh {7 10}} \ {2 1 1 {} {-1 -1}} \ {3 1 1 123435 {12 17}}] \ [list {0 1 1 HIJK {0 3}} \ {1 1 1 efgh {7 10}} \ {2 1 1 {} {-1 -1}} \ {3 1 1 123435 {12 17}}] \ [list {0 1 1 {} {-1 -1}} \ {1 1 1 efgh {7 10}} \ {2 1 1 X {12 12}} \ {3 1 1 123435 {13 18}}] \ [list {0 1 1 HIJK {0 3}} \ {1 1 1 efgh {7 10}} \ {2 1 1 X {12 12}} \ {3 1 1 123435 {13 18}}]] close $testFH scancontext delete $testCH set testCH [scancontext create] Test filescan-7.1 {filescan tests} { scanmatch $testCH {a[} {} } 1 {couldn't compile regular expression pattern: brackets [] not balanced} # # Test the copy file manipulation by sorting a file of numbered lines into two # files of odd and even. # set testFH [open TEST.TMP w] loop cnt 0 101 { puts $testFH "Line $cnt" puts $testFH "Match me" } close $testFH set testFH [open TEST.TMP r] set testChkFH [open TESTCHK.TMP w] set testChk2FH [open TESTCHK2.TMP w] set testCH [scancontext create] scancontext copyfile $testCH $testChkFH Test filescan-8.1 {filescan tests} { scancontext copyfile $testCH } 0 $testChkFH scanmatch $testCH {^Match me$} { if [cequal [scancontext copyfile $matchInfo(context)] $testChkFH] { scancontext copyfile $matchInfo(context) $testChk2FH } elseif [cequal [scancontext copyfile $matchInfo(context)] $testChk2FH] { scancontext copyfile $matchInfo(context) $testChkFH } else { Test filescan-8.2 {filescan tests} { scancontext copyfile $matchInfo(context) } 0 "should have been $testChkFH or $testChk2FH" } } scanfile $testCH $testFH close $testFH close $testChkFH close $testChk2FH scancontext delete $testCH set testChkFH [open TESTCHK.TMP r] set testChk2FH [open TESTCHK2.TMP r] loop cnt 0 101 2 { Test filescan-8.3 {filescan tests} { gets $testChkFH } 0 "Line $cnt" } loop cnt 1 101 2 { Test filescan-8.4 {filescan tests} { gets $testChk2FH } 0 "Line $cnt" } close $testChkFH close $testChk2FH # # Test for the problem De Clarke found with Boyer-Moore. # Test 9.1 {filescan tests} { set testFH [open TEST.TMP w] puts $testFH \ {Sun Dec 01 14:56:08 1996 mask1a.ps kelson bigdog.ucolick.org 1} close $testFH set linesMatched {} set testCH [scancontext create] scanmatch $testCH {[A-z] Dec [0-9]* [0123456789:]* 1996 } { lappend linesMatched $matchInfo(line) } set testFH [open TEST.TMP] scanfile $testCH $testFH close $testFH set linesMatched } 0 {{Sun Dec 01 14:56:08 1996 mask1a.ps kelson bigdog.ucolick.org 1}} # # Test some regexps that have caused probelms in the past. # Test 9.2 {filescan tests} { set ch [scancontext create] scanmatch -nocase $ch {^[a-z]} {echo foo} scancontext delete $ch } 0 {} Test 9.3 {filescan tests} { # Tuende Kriegl says this # panics on NT but not unix! set ch [scancontext create] scanmatch $ch {([^(]*).'([^']*).*%OpText %(.*)} {echo foo} scancontext delete $ch } 0 {} Test 9.1 {filescan tests} { set testFH [open TEST.TMP w] puts $testFH "foo\nbar" close $testFH set linesMatched {} set testCH [scancontext create] scanmatch $testCH {foo|bar} { lappend linesMatched $matchInfo(line) } set testFH [open TEST.TMP] scanfile $testCH $testFH close $testFH set linesMatched } 0 {foo bar} TestRemove TEST.TMP TEST2.TMP TESTCHK.TMP TESTCHK2.TMP rename GenScanRec {} rename ValMatch {} rename ValScan {} rename ChkSubMatch {} unset matchCnt chkMatchCnt matchInfo testFH test2FH testChkFH testChk2FH tclx8.4-8.4.1.orig/tests/flock.test0000644000000000000000000001642312046313167013727 0ustar # # flock.test # # Tests for the flock and funlock commands. #--------------------------------------------------------------------------- # Copyright 1992-1999 Karl Lehenbauer and Mark Diekhans. # # Permission to use, copy, modify, and distribute this software and its # documentation for any purpose and without fee is hereby granted, provided # that the above copyright notice appear in all copies. Karl Lehenbauer and # Mark Diekhans make no representations about the suitability of this # software for any purpose. It is provided "as is" without express or # implied warranty. #------------------------------------------------------------------------------ # $Id: flock.test,v 1.3 2002/04/03 02:44:21 hobbs Exp $ #------------------------------------------------------------------------------ # if {[cequal [info procs Test] {}]} { source [file join [file dirname [info script]] testlib.tcl] } if ![infox have_flock] { if [cequal $tcl_platform(platform) windows] { puts "File locking is not available on this Unix system, tests skipped" } else { puts "File locking is not available on this version of Windows" } return } TestRemove FLOCKR.TMP FLOCKRW.TMP FLOCKW.TMP FLOCK.PRG # # Create and open a read file and a write file. # foreach X {R W RW} { set fh [open FLOCK${X}.TMP w] puts $fh [replicate X 100] close $fh } set readFH [open FLOCKR.TMP r] set writeFH [open FLOCKW.TMP w] set rdwrFH [open FLOCKRW.TMP r+] # # Check flock argument checking # set flockWrongArgs {wrong # args: flock ?-read|-write? ?-nowait? fileId ?start? ?length? ?origin?} Test flock-1.1 {flock argument checking} { flock } 1 $flockWrongArgs Test flock-1.2 {flock argument checking} { flock $readFH 0 0 0 0 } 1 $flockWrongArgs Test flock-1.3 {flock argument checking} { flock -writx $readFH } 1 {invalid option "-writx" expected one of "-read", "-write", or "-nowait"} Test flock-1.4 {flock argument checking} { flock -nowait } 1 $flockWrongArgs Test flock-1.5 {flock argument checking} { flock foofile } 1 {can not find channel named "foofile"} Test flock-1.6 {flock argument checking} { flock -read $readFH x } 1 {expected integer but got "x"} Test flock-1.7 {flock argument checking} { flock -read $readFH 1 x } 1 {expected integer but got "x"} Test flock-1.8 {flock argument checking} { flock -read $readFH {} x } 1 {expected integer but got "x"} Test flock-1.9 {flock argument checking} { flock -read $readFH {} 1 bad } 1 {bad origin "bad": should be "start", "current", or "end"} Test flock-1.10 {flock argument checking} { flock -read -write $rdwrFH } 1 {can not specify both "-read" and "-write"} # # Check funlock argument checking # set funlockWrongArgs {wrong # args: funlock fileId ?start? ?length? ?origin?} Test flock-2.1 {funlock argument checking} { funlock } 1 $funlockWrongArgs Test flock-2.2 {funlock argument checking} { funlock $readFH 0 0 0 0 } 1 $funlockWrongArgs Test flock-2.3 {funlock argument checking} { funlock -write $readFH } 1 {can not find channel named "-write"} Test flock-2.4 {funlock argument checking} { funlock foofile } 1 {can not find channel named "foofile"} Test flock-2.5 {funlock argument checking} { funlock $readFH x } 1 {expected integer but got "x"} Test flock-2.6 {funlock argument checking} { funlock $readFH 1 x } 1 {expected integer but got "x"} Test flock-2.7 {funlock argument checking} { funlock $readFH {} x } 1 {expected integer but got "x"} Test flock-2.8 {funlock argument checking} { funlock $readFH {} 1 bad } 1 {bad origin "bad": should be "start", "current", or "end"} # # If problems with acquiring locks, bail out now, as some tests may hang. # Suns are especially bad at hanging. It appears that having some data in # a file and only locking part of it will cause this test to fail rather # than hang on a confused system. # if [cequal $tcl_platform(platform) "unix"] { ;# FIX: port to win alarm 10 } puts $writeFH "This is some silly text to help prevent hangs" flush $writeFH if {[catch {flock $writeFH 0 8} msg] != 0} { if [cequal $tcl_platform(platform) "unix"] { ;# FIX: port to win alarm 0 } puts "*************************************************************" puts "Error acquiring file lock. This is probably caused by an" puts "incorrectly configured system or bug in the system software." puts "If NFS is involved, make sure lockd is correctly configured" puts "The error message returned was:" puts " $msg" puts "*************************************************************" catch {close $writeFH} catch {close $readFH} catch {close $rdwrFH} TestRemove FLOCKR.TMP FLOCKW.TMP FLOCKRW.TMP FLOCK.PRG return } if [cequal $tcl_platform(platform) "unix"] { ;# FIX: port to win alarm 0 } funlock $writeFH 0 8 # # Check locking read/write access checking. # Test flock-3.1 {flock argument checking} { flock $readFH } 1 "channel \"$readFH\" wasn't opened for writing" Test flock-3.2 {flock argument checking} { flock -write $readFH } 1 "channel \"$readFH\" wasn't opened for writing" Test flock-3.3 {flock argument checking} { flock -read $writeFH } 1 "channel \"$writeFH\" wasn't opened for reading" # # Check locking of a file that is not locked # Test flock-4.1 {flock/unlock of a file that is not locked} { flock $writeFH funlock $writeFH } 0 {} Test flock-4.2 {flock/unlock of a file that is not locked} { flock -write $writeFH funlock $writeFH } 0 {} Test flock-4.3 {flock/unlock of a file that is not locked} { flock -write $rdwrFH funlock $rdwrFH } 0 {} Test flock-4.4 {flock/unlock of a file that is not locked} { flock -read $readFH funlock $readFH } 0 {} # # Start a process to lock a file. Write something to stdout to indicate # that the process is running. Wait for something on stdin to exit. # set fh [open FLOCK.PRG w] puts $fh { package require Tclx fconfigure stdout -buffering line set writeFH [open FLOCKW.TMP WRONLY] set rdwrFH [open FLOCKRW.TMP RDWR] flock $writeFH flock $rdwrFH 0 10 puts "*I am ready*" if {[gets stdin line] < 0} { puts stderr "unexpected EOF in flock child" exit 1 } if ![cequal $line "*STOP, Please*"] { puts stderr "unexpected input in flock child: \"$line\"" exit 1 } exit 0 } close $fh set childFH [open "|[list $::tcltest::tcltest FLOCK.PRG]" r+] if {[gets $childFH line] < 0} { error "Unexpected EOF from flock test child" } if ![cequal $line "*I am ready*"] { error "Unexpected response from flock test child: $line" } Test flock-5.1 {flock of file locked by child process} { flock -nowait $writeFH } 0 0 Test flock-5.2 {flock of file locked by child process} { flock -nowait $rdwrFH 0 5 } 0 0 Test flock-5.3 {flock of file locked by child process} { flock -nowait $rdwrFH 0 5 start } 0 0 set rdwrSize [fstat $rdwrFH size] Test flock-5.4 {flock of file locked by child process} { flock -nowait $rdwrFH -$rdwrSize 5 end } 0 0 Test flock-5.4 {flock of file locked by child process} { set stat [flock -nowait $rdwrFH 10 12 start] funlock $rdwrFH 10 12 start set stat } 0 1 puts $childFH "*STOP, Please*" flush $childFH close $childFH catch {close $readFH} catch {close $writeFH} catch {close $rdwrFH} TestRemove FLOCKR.TMP FLOCKW.TMP FLOCKRW.TMP FLOCK.PRG tclx8.4-8.4.1.orig/tests/string.test0000644000000000000000000002273712046313167014144 0ustar # # string.test # # Tests for the string-related commands. #--------------------------------------------------------------------------- # Copyright 1992-1999 Karl Lehenbauer and Mark Diekhans. # # Permission to use, copy, modify, and distribute this software and its # documentation for any purpose and without fee is hereby granted, provided # that the above copyright notice appear in all copies. Karl Lehenbauer and # Mark Diekhans make no representations about the suitability of this # software for any purpose. It is provided "as is" without express or # implied warranty. #------------------------------------------------------------------------------ # $Id: string.test,v 1.3 2002/09/26 00:19:02 hobbs Exp $ #------------------------------------------------------------------------------ # if {[cequal [info procs Test] {}]} { source [file join [file dirname [info script]] testlib.tcl] } # Test the 'cindex' command. Test string-1.1 {cindex tests} { cindex ABCDEFG 1 } 0 {B} Test string-1.2 {cindex tests} { cindex ABCDEFG 3+1 } 0 {E} Test string-1.3 {cindex tests} { cindex ABCDEFG 3*2 } 0 {G} Test string-1.4 {cindex tests} { cindex ABCDEFG 7 } 0 {} Test string-1.5 {cindex tests} { cindex ABCDEFG end-2 } 0 {E} Test string-1.6 {cindex tests} { cindex ABCDEFG len-3 } 0 {E} Test string-1.7 {cindex tests} { cindex ABCDEFG lenx-3 } 1 "syntax error in expression \"7x-3\"[expr { ($tcl_version>8.3) ? ": extra tokens at end of expression" : "" }]" Test string-1.8 {cindex tests} { cindex ABCDEFG } 1 {wrong # args: cindex string indexExpr} Test string-1.9 {cindex tests} { cindex ABCDEFG 1 10 } 1 {wrong # args: cindex string indexExpr} Test string-1.10 {cindex tests} { cindex A\0BCDEFG 2 } 0 {B} Test string-1.11 {cindex tests} { cindex A\0BCDEFG 1 } 0 "\0" Test string-1.12 {cindex unicode tests} { cindex \u7266abc\u7266x 1 } 0 "a" Test string-1.13 {cindex unicode tests} { cindex \u7266abc\u7266x 0 } 0 "\u7266" Test string-1.14 {cindex unicode tests} { cindex \u7266abc\u7266x 4 } 0 "\u7266" Test string-1.15 {cindex unicode tests} { cindex \u7266abc\u7266x 5 } 0 "x" # Test the 'clength' command. Test string-2.1 {clength tests} { clength ABCDEFG } 0 7 Test string-2.2 {clength tests} { clength "ABCD XYZ" } 0 8 Test string-2.3 {clength tests} { clength } 1 {wrong # args: clength string} Test string-2.4 {clength tests} { clength "AB\0D X\0Z" } 0 8 Test string-2.5 {clength unicode tests} { clength \u7266abc\u7266x } 0 6 Test string-2.6 {clength unicode tests} { clength abc\u7266x\u7266 } 0 6 # Test the crange command. Test string-3.1 {crange tests} { crange ABCDEFG 1 3 } 0 {BCD} Test string-3.2 {crange tests} { crange ABCDEFG 2 end } 0 {CDEFG} Test string-3.3 {crange tests} { set foo [replicate ABCD 500] crange $foo 25*4 500-1 } 0 [replicate ABCD 100] Test string-3.4 {crange tests} { crange } 1 {wrong # args: crange string firstExpr lastExpr} Test string-3.5 {crange tests} { crange ABCD 4 1 } 0 {} Test string-3.6 {crange tests} { crange ABCD end-2 len-1 } 0 {BCD} Test string-3.7 {crange tests} { crange ABCD len-3 end-1 } 0 {BC} Test string-3.8 {crange tests} { # 8.4+ enhanced the error return from expressions crange ABCD lenx-3 end-1 } 1 "syntax error in expression \"4x-3\"[expr { ($tcl_version>8.3) ? ": extra tokens at end of expression" : "" }]" Test string-3.9 {crange tests} { set text .tex set l 4 crange $text $l+1 end } 0 {} Test string-3.10 {crange tests} { crange AB\0DEFG 1 3 } 0 "B\0D" Test string-3.11 {crange tests} { crange ABC\0E\0G 2 end } 0 "C\0E\0G" Test string-3.12 {crange unicode tests} { crange \u7266abc\u7266x 2 end } 0 "bc\u7266x" # Test the 'replicate' command Test string-4.1 {replicate tests} { replicate AbCd 4 } 0 {AbCdAbCdAbCdAbCd} Test string-4.2 {replicate tests} { replicate X 1000 } 0 "[replicate X 250][replicate X 250][replicate X 250][replicate X 250]" Test string-4.3 {replicate tests} { replicate X } 1 {wrong # args: replicate string countExpr} Test string-4.4 {replicate tests} { replicate Ab\0d 4 } 0 "Ab\0dAb\0dAb\0dAb\0d" Test string-4.5 {replicate unicode tests} { replicate \u7266abc\u7266x 3 } 0 "\u7266abc\u7266x\u7266abc\u7266x\u7266abc\u7266x" # Test the csubstr command. Test string-5.1 {csubstr tests} { csubstr ABCDEFG 1 2+1 } 0 {BCD} Test string-5.2 {csubstr tests} { csubstr ABCDEFG 1+1 end } 0 {CDEFG} Test string-5.3 {csubstr tests} { set foo [replicate ABCD 500] csubstr $foo 25*4 100*4 } 0 [replicate ABCD 100] Test string-5.4 {csubstr tests} { csubstr } 1 {wrong # args: csubstr string firstExpr lengthExpr} Test string-5.5 {csubstr tests} { csubstr ABCD 4 1 } 0 {} Test string-5.6 {csubstr tests} { csubstr ABCD 1 end-1 } 0 {BC} Test string-5.7 {csubstr tests} { csubstr ABCD len-2 end } 0 {CD} Test string-5.8 {csubstr tests} { csubstr ABCD 0 len } 0 {ABCD} Test string-5.9 {csubstr tests} { csubstr AB\0D len-2 end } 0 "\0D" Test string-5.8 {csubstr tests} { csubstr AB\0D 0 len } 0 "AB\0D" Test string-5.9 {csubstr unicode tests} { csubstr \u7266abc\u7266x 0 1 } 0 \u7266 Test string-5.10 {csubstr unicode tests} { csubstr \u7266abc\u7266x 1 end-1 } 0 abc\u7266 # Test the translit command. Test string-6.1 {translit tests} { set str "Captain Midnight Secret Decoder Ring" translit {A-MN-Za-mn-z} {N-ZA-Mn-za-m} $str } 0 {Pncgnva Zvqavtug Frperg Qrpbqre Evat} Test string-6.2 {translit tests} { set str "Captain Midnight Secret Decoder Ring" set str2 [translit {A-MN-Za-mn-z} {N-ZA-Mn-za-m} $str] translit {A-MN-Za-mn-z} {N-ZA-Mn-za-m} $str2 } 0 {Captain Midnight Secret Decoder Ring} Test string-6.4 {translit tests} { translit } 1 {wrong # args: translit from to string} # Type conversion was broken. Test string-6.5 {translit tests} { catch {unset xxx} set s [list This_is_a_test value] array set xxx [translit _ - $s] array get xxx } 0 {This-is-a-test value} catch {unset xxx} # Check for detection of unsupported UniCode Test string-6.6 {translit tests} { set str "Captain Midnight Secret Decoder Ring" translit "A-MN-Za-m\u1234-z" "N-ZA-Mn-za-m" $str } 1 {Unicode character found in in-range, the translit command does not yet support Unicode} Test string-6.7 {translit tests} { set str "Captain Midnight Secret Decoder Ring" translit "A-MN-Za-mn-z" "N-ZA-Mn-za-\u5134" $str } 1 {Unicode character found in out-range, the translit command does not yet support Unicode} Test string-6.8 {translit tests} { set str "Captain Midnight Secret \u1543ecoder Ring" translit "A-MN-Za-mn-z" "N-ZA-Mn-za-m" $str } 1 {Unicode character found in string to translate, the translit command does not yet support Unicode} # Test the ctoken command Test string-7.1 {ctoken tests} { ctoken } 1 {wrong # args: ctoken strvar separators} Test string-7.2 {ctoken tests} { ctoken a b c } 1 {wrong # args: ctoken strvar separators} Test string-7.3 {ctoken tests} { set orgstr " \t this\tis \n a test " set s1 [ctoken orgstr " \t\n"] set s1v $orgstr set s2 [ctoken orgstr " \t\n"] set s2v $orgstr set s3 [ctoken orgstr " \t\n"] set s3v $orgstr set s4 [ctoken orgstr " \t\n"] set s4v $orgstr set s5 [ctoken orgstr " \t\n"] set s5v $orgstr list $s1 $s1v $s2 $s2v $s3 $s3v $s4 $s4v $s5 $s5v } 0 [list "this" "\tis \n a test " \ "is" " \n a test " \ "a" " test " \ "test" " " \ "" ""] Test string-7.2 {ctoken tests} { ctoken "No such variable" " \t" } 1 {can't read "No such variable": no such variable} Test string-9.1 {cequal tests} { cequal } 1 {wrong # args: cequal string1 string2} Test string-9.2 {cequal tests} { cequal a b c } 1 {wrong # args: cequal string1 string2} Test string-9.3 {cequal tests} { cequal ab c } 0 0 Test string-9.4 {cequal tests} { cequal abcded abcded } 0 1 Test string-9.5 {cequal tests} { cequal a\0 a } 0 0 Test string-9.6 {cequal tests} { cequal ab\0cd\0ed ab\0cd\0ed } 0 1 Test string-9.7 {cequal tests} { cequal file5 file4 } 0 0 Test string-9.8 {cequal unicode tests} { cequal \u7266abc\u7266x \u7266abc\u7266x } 0 1 Test string-9.9 {cequal unicode tests} { cequal \u7266abc\u7267x \u7266abc\u7266x } 0 0 # ccollate command Test string-10.1 {ccollate tests} { ccollate } 1 {wrong # args: ccollate ?options? string1 string2} Test string-10.2 {ccollate tests} { ccollate aaa bbb ccc ddd } 1 {wrong # args: ccollate ?options? string1 string2} Test string-10.3 {ccollate tests} { ccollate -bbb ccc ddd } 1 {Invalid option "-bbb", expected "-local"} Test string-10.4 {ccollate tests} { ccollate nnn ccc ddd } 1 {Invalid option "nnn", expected "-local"} Test string-10.5 {ccollate tests} { ccollate abcdef abcdef } 0 0 Test string-10.6 {ccollate tests} { ccollate abcdefg abcdef } 0 1 Test string-10.7 {ccollate tests} { ccollate abcde abcdef } 0 -1 Test string-10.8 {ccollate tests} { ccollate -local abcdefg abcdef } 0 1 Test string-10.9 {ccollate tests} { ccollate -local abcde abcdef } 0 -1 Test string-11.1 {cconcat tests} { cconcat } 0 {} Test string-11.2 {cconcat tests} { cconcat Aaa Bbb } 0 {AaaBbb} Test string-11.3 {cconcat tests} { cconcat Aaa " " Bbb } 0 {Aaa Bbb} Test string-11.4 {cconcat tests} { cconcat A\0a B\0b } 0 "A\0aB\0b" Test string-11.4 {cconcat tests} { cconcat Aaa " " \0 Bbb } 0 "Aaa \0Bbb" # cleanup ::tcltest::cleanupTests return tclx8.4-8.4.1.orig/tests/pushd.test0000644000000000000000000000501112046313167013743 0ustar # # pushd.test # # Tests for tcl.tlib directory directory stack routines. # #--------------------------------------------------------------------------- # Copyright 1992-1999 Karl Lehenbauer and Mark Diekhans. # # Permission to use, copy, modify, and distribute this software and its # documentation for any purpose and without fee is hereby granted, provided # that the above copyright notice appear in all copies. Karl Lehenbauer and # Mark Diekhans make no representations about the suitability of this # software for any purpose. It is provided "as is" without express or # implied warranty. #------------------------------------------------------------------------------ # $Id: pushd.test,v 1.2 2002/04/02 02:29:43 hobbs Exp $ #------------------------------------------------------------------------------ # if {[cequal [info procs Test] {}]} { source [file join [file dirname [info script]] testlib.tcl] } # # Get the directories we are going to be using. Also the device for # windows. Always get absolute paths via cd-ing and pwd, in case the directory # is symbolicly linked. # switch $tcl_platform(platform) { unix { set tmp /tmp } windows { if [cequal $tcl_platform(os) {Windows NT}] { set tmp {C:/Program Files} } else { set tmp C:/dos } } } if ![file isdirectory $tmp] { puts "*************************************************************" puts "Directory $tmp does not exist, pushd & popd tests" puts "will be skipped" puts "*************************************************************" return } set CWD [pwd] set CWDROOT [lindex [file split $CWD] 0] cd $tmp set TMP [pwd] set TMPROOT [lindex [file split $TMP] 0] Test pushd-1.1 {pushd command} { pushd } 1 {directory stack empty} Test pushd-1.2 {pushd command} { pushd $TMP set TCLXENV(dirPushList) } 0 [list $TMP] Test pushd-1.3 {pushd command} { pushd $CWDROOT } 0 $CWDROOT Test pushd-1.4 {pushd command} { pushd $TMP set TCLXENV(dirPushList) } 0 [list $CWDROOT $TMP $TMP] Test pushd-1.5 {pushd command} { dirs } 0 [list $TMP $CWDROOT $TMP $TMP] cd $CWD Test popd-1.1 {popd command} { popd } 0 $CWDROOT Test popd-1.2 {popd command} { dirs } 0 [list $CWDROOT $TMP $TMP] Test popd-1.3 {popd command} { list [popd] [popd] [dirs] } 0 [list $TMP $TMP [list $TMP]] Test popd-1.4 {popd command} { popd } 1 {directory stack empty} Test popd-1.4 {popd command} { set TCLXENV(dirPushList) } 0 {} cd $CWD # cleanup ::tcltest::cleanupTests return tclx8.4-8.4.1.orig/tests/unixcmds.test0000644000000000000000000001014312046313167014454 0ustar # # unixcmds.test # # Tests for the link, times, umask, system and sleep commands. #--------------------------------------------------------------------------- # Copyright 1992-1999 Karl Lehenbauer and Mark Diekhans. # # Permission to use, copy, modify, and distribute this software and its # documentation for any purpose and without fee is hereby granted, provided # that the above copyright notice appear in all copies. Karl Lehenbauer and # Mark Diekhans make no representations about the suitability of this # software for any purpose. It is provided "as is" without express or # implied warranty. #------------------------------------------------------------------------------ # $Id: unixcmds.test,v 1.3 2002/04/04 06:10:30 hobbs Exp $ #------------------------------------------------------------------------------ # if {[cequal [info procs Test] {}]} { source [file join [file dirname [info script]] testlib.tcl] } # # Fork without exec will not work under Tk, skip this test # if {[info exists tk_version]} { puts "****************************************************************" puts "Unix commmands tests require fork, which does not work under Tk." puts "Test skipped." puts "****************************************************************" return } TestRemove MKDIR1.TMP MKDIR2.TMP # Proc to create a small file. proc TestCreate {fname} { set fh [open $fname w] puts $fh "Hello, world" close $fh } # Test the link command. test unixcmds-1.1 {link tests} {unixOnly} { TestRemove LINK2.TMP TestCreate LINK1.TMP link LINK1.TMP LINK2.TMP catch {unset stat} file stat LINK1.TMP stat set ino1 $stat(ino) set dev1 $stat(dev) file stat LINK2.TMP stat set ino2 $stat(ino) set dev2 $stat(dev) set result [list [file exists LINK2.TMP] [expr $ino1==$ino2] \ [expr $dev1==$dev2]] TestRemove LINK1.TMP LINK2.TMP set result } {1 1 1} test unixcmds-1.2 {link tests} unixOnly { list [catch {link LINK1.TMP LINK2.TMP} msg] [string tolower $msg] } {1 {linking "link1.tmp" to "link2.tmp" failed: no such file or directory}} test unixcmds-1.3 {link tests} { list [catch {link} msg] $msg } {1 {wrong # args: link ?-sym? srcpath destpath}} # Test -sym only if we have symbolic links. test unixcmds-1.4 {link tests} {need_symlink} { TestRemove LINK2.TMP TestCreate LINK1.TMP link -sym LINK1.TMP LINK2.TMP catch {unset stat} set result [file readlink LINK2.TMP] TestRemove LINK1.TMP LINK2.TMP set result } {LINK1.TMP} test unixcmds-1.4 {link tests} {pcOnly} { link LINK1.TMP LINK2.TMP } {1 {link is not available on MS Windows}} # Test the times command (the best we can). test unixcmds-3.1 {times tests} {unixOnly} { llength [times] } 4 test unixcmds-3.2 {times tests} {unixOnly} { list [catch {times foo} msg] $msg } {1 {wrong # args: times}} # Test umask command. test unixcmds-4.1 {umask tests} {unixOnly} { set oldMask [umask] umask 666 set newMask [umask] umask $oldMask set newMask } 666 test unixcmds-4.2 {umask tests} { list [catch {umask 999} msg] $msg } {1 {Expected octal number got: 999}} test unixcmds-4.3 {umask tests} { list [catch {umask 7 7} msg] $msg } {1 {wrong # args: umask ?octalmask?}} # Test the system command test unixcmds-5.1 {system tests} {unixOnly} { system "ls / >/dev/null" } 0 test unixcmds-5.1.1 {system tests} {unixOnly} { system ls / >/dev/null } 0 test unixcmds-5.2 {system tests} {unixOnly} { list [catch {system} msg] $msg } {1 {wrong # args: system cmdstr1 ?cmdstr2...?}} test unixcmds-5.3 {system tests} {unixOnly} { system exit 3 } 3 test unixcmds-5.4 {system tests} {unixOnly} { system "exit 3" } 3 test unixcmds-5.5 {system tests} {unixOnly} { system "exit 101" } 101 # Test the sleep command, as well as we can. test unixcmds-6.1 {sleep tests} { sleep 1 } {} test unixcmds-6.2 {sleep tests} { list [catch {sleep} msg] $msg } {1 {wrong # args: sleep seconds}} test unixcmds-6.3 {sleep tests} { list [catch {sleep 1 2} msg] $msg } {1 {wrong # args: sleep seconds}} # cleanup ::tcltest::cleanupTests return tclx8.4-8.4.1.orig/tests/init.test0000644000000000000000000000235112046313167013567 0ustar # # init.test # # Tests for various TclX initialization functionality (safe interp, # dynamic load, etc). #--------------------------------------------------------------------------- # Copyright 1996-1999 Karl Lehenbauer and Mark Diekhans. # # Permission to use, copy, modify, and distribute this software and its # documentation for any purpose and without fee is hereby granted, provided # that the above copyright notice appear in all copies. Karl Lehenbauer and # Mark Diekhans make no representations about the suitability of this # software for any purpose. It is provided "as is" without express or # implied warranty. #------------------------------------------------------------------------------ # $Id: init.test,v 1.2 2002/04/02 02:29:43 hobbs Exp $ #------------------------------------------------------------------------------ # if {[cequal [info procs Test] {}]} { source [file join [file dirname [info script]] testlib.tcl] } Test init-1.0 {safe interp with TclX} { set si [interp create -safe] load {} Tclx $si interp eval $si package require Tclx set xcmds [interp eval $si info commands keyl*] interp delete $si lsort $xcmds } 0 {keyldel keylget keylkeys keylset} # cleanup ::tcltest::cleanupTests return tclx8.4-8.4.1.orig/tests/socket.test0000644000000000000000000000401312046313167014111 0ustar # # socket.test # # Test for socket and network related commands. #------------------------------------------------------------------------------ # Copyright 1992-1999 Karl Lehenbauer and Mark Diekhans. # # Permission to use, copy, modify, and distribute this software and its # documentation for any purpose and without fee is hereby granted, provided # that the above copyright notice appear in all copies. Karl Lehenbauer and # Mark Diekhans make no representations about the suitability of this # software for any purpose. It is provided "as is" without express or # implied warranty. #------------------------------------------------------------------------------ # $Id: socket.test,v 1.2 2002/04/02 02:29:43 hobbs Exp $ #------------------------------------------------------------------------------ # if {[cequal [info procs Test] {}]} { source [file join [file dirname [info script]] testlib.tcl] } if [cequal $tcl_platform(platform) windows] { echo " * The socket tests have not been ported to Win32" return } # # Do all argument and error checking. We can at least test this, even # if we can't run full tests on this particular system. # Test socket-1.0 {host_info argument checking} { host_info } 1 {wrong # args: host_info option ...} Test socket-1.1 {host_info argument checking} { host_info addresses } 1 {wrong # args: host_info addresses host} Test socket-1.2 {host_info argument checking} { host_info addresses xxx yyy } 1 {wrong # args: host_info addresses host} Test socket-1.3 {host_info argument checking} { host_info bad localhost } 1 {invalid option "bad", expected one of "addresses", "official_name", or "aliases"} # # Determine if we are at a development site we know is good. If we are, we # do more checking. # switch -glob -- [id host] { {*.neosoft.com} {set safeHost 1} {*.grizzly.com} {set safeHost 1} default {set safeHost 0} } if [info exists env(TCLX_FULL_TESTS)] { set safeHost 1 } # FIX: Add hostinfo tests. # cleanup ::tcltest::cleanupTests return tclx8.4-8.4.1.orig/tests/readdir.test0000644000000000000000000000326412046313167014242 0ustar # # readdir.test # # Tests for the readdir command. #--------------------------------------------------------------------------- # Copyright 1992-1999 Karl Lehenbauer and Mark Diekhans. # # Permission to use, copy, modify, and distribute this software and its # documentation for any purpose and without fee is hereby granted, provided # that the above copyright notice appear in all copies. Karl Lehenbauer and # Mark Diekhans make no representations about the suitability of this # software for any purpose. It is provided "as is" without express or # implied warranty. #------------------------------------------------------------------------------ # $Id: readdir.test,v 1.2 2002/04/02 02:29:43 hobbs Exp $ #------------------------------------------------------------------------------ # if {[cequal [info procs Test] {}]} { source [file join [file dirname [info script]] testlib.tcl] } catch {eval file delete [glob -nocomplain READDIR.TMP/*]} catch {file delete READDIR.TMP} Test readdir-1.1 {readdir tests} { readdir } 1 {wrong # args: readdir ?-hidden? dirPath} Test readdir-1.1.1 {readdir tests} { readdir -hidden x y } 1 {wrong # args: readdir ?-hidden? dirPath} Test readdir-1.2 {readdir tests} { readdir -x y } 1 {expected option of "-hidden", got "-x"} TestTouch READDIR.TMP/AAA TestTouch READDIR.TMP/BBB TestTouch READDIR.TMP/CCC TestTouch READDIR.TMP/DDD Test readdir-1.3 {readdir tests} { lsort [readdir READDIR.TMP] } 0 {AAA BBB CCC DDD} Test readdir-1.4 {readdir tests} { lsort [readdir -hidden READDIR.TMP] } 0 {AAA BBB CCC DDD} catch {eval file delete [glob -nocomplain READDIR.TMP/*]} catch {file delete READDIR.TMP} # cleanup ::tcltest::cleanupTests return tclx8.4-8.4.1.orig/tests/compat/0000755000000000000000000000000012046525461013207 5ustar tclx8.4-8.4.1.orig/tests/compat/clock.test0000644000000000000000000001027712046313167015210 0ustar # # clock.test # # Tests for deprecated TclX clock commands: getclock, fmtclock and # convertclock. #--------------------------------------------------------------------------- # Copyright 1992-1999 Karl Lehenbauer and Mark Diekhans. # # Permission to use, copy, modify, and distribute this software and its # documentation for any purpose and without fee is hereby granted, provided # that the above copyright notice appear in all copies. Karl Lehenbauer and # Mark Diekhans make no representations about the suitability of this # software for any purpose. It is provided "as is" without express or # implied warranty. #------------------------------------------------------------------------------ # $Id: clock.test,v 1.1 2001/10/24 23:31:49 hobbs Exp $ #------------------------------------------------------------------------------ # # FIX: Currently strftime use of %Z (or any unknown format spec) causes core # dumps on MS VC++. Remove constraints when base Tcl works around the problem. if [cequal [info procs Test] {}] {source testlib.tcl} eval $SAVED_UNKNOWN # Try getclock, hard to test the result, make sure its a number Test clock-1.1 {getclock tests} { expr [getclock]+1 concat {} } 0 {} Test clock-1.2 {getclock tests} { getclock 1990 } 1 {called "getclock" with too many arguments} # Test fmtclock Test clock-2.1 {fmtclock tests} { set clockval 657687766 fmtclock $clockval {%a %b %d %I:%M:%S %p %Y} GMT } 0 {Sun Nov 04 03:02:46 AM 1990} Test clock-2.2 {fmtclock tests} { fmtclock } 1 {no value given for parameter "clockval" to "fmtclock"} set large [replicate XYZabc 500] Test clock-2.2 {fmtclock tests} { set clockval 657687766 fmtclock $clockval "%a %b %d %I:%M:%S %p %Y $large" GMT } 0 "Sun Nov 04 03:02:46 AM 1990 $large" unset large # Test convertclock Test clock-3.1 {convertclock tests} { convertclock } 1 {no value given for parameter "dateString" to "convertclock"} Test clock-3.2 {convertclock tests} { fmtclock [convertclock "14 Feb 92" GMT] {%m/%d/%y %I:%M:%S %p} GMT } 0 {02/14/92 12:00:00 AM} Test clock-3.3 {convertclock tests} { fmtclock [convertclock "Feb 14, 1992 12:20 PM" GMT] {%m/%d/%y %I:%M:%S %p} GMT } 0 {02/14/92 12:20:00 PM} Test clock-3.5 {convertclock tests} { fmtclock [convertclock "Feb 14, 1992 12:20 PM" {GMT} 319363200] {%m/%d/%y %I:%M:%S %p} GMT } 0 {02/14/92 12:20:00 PM} Test clock-3.6 {convertclock tests} { set clock [convertclock "Oct 23,1992 15:00"] fmtclock $clock {%b %d,%Y %H:%M} } 0 {Oct 23,1992 15:00} Test clock-3.7 {convertclock tests} { set clock [convertclock "Oct 23,1992 15:00 GMT"] fmtclock $clock {%b %d,%Y %H:%M GMT} GMT } 0 {Oct 23,1992 15:00 GMT} Test clock-3.8 {convertclock tests} { set clock [convertclock "Oct 23,1992 15:00" GMT] fmtclock $clock {%b %d,%Y %H:%M GMT} GMT } 0 {Oct 23,1992 15:00 GMT} # Test if local timezone works when not explicitly specified. Test clock-3.9 {convertclock tests} { # WARNING: This test might fail if your symbolic timezone name conflicts # with names use in other parts of the world or if the symbolic zone is # returns an incorrect value. # # o EST for Australian Eastern Summer Time. # o EST for Australian Eastern Standard Time. # o On some systems, a "TZ=GMT+2" results in strftime returning a # time zone of just "GMT". # # Don't worry about these failures. set clock [getclock] set ourzone [fmtclock $clock %Z] set intime [fmtclock $clock {%a %h %d %T %Y}] set cnv1 [convertclock $intime] set cnv2 [convertclock "$intime $ourzone"] if {$cnv1 == $cnv2} { concat OK } else { error "different resulting times: $cnv1, $cnv2" } } 0 OK {tempNotPc} set fmt {%m/%d/%y %I:%M:%S %p} foreach hour {01 02 03 04 05 06 07 08 09 10 11 12} { foreach min {00 01 59} { foreach med {AM PM} { Test clock-4.0 {convertclock tests} { fmtclock [convertclock "1/1/72 $hour:$min:00 $med"] $fmt } 0 "01/01/72 $hour:$min:00 $med" Test clock-4.1 {convertclock tests} { fmtclock [convertclock "1/1/72 $hour:$min:00 $med" GMT] $fmt GMT } 0 "01/01/72 $hour:$min:00 $med" {unixOnly} } } } rename unknown {} tclx8.4-8.4.1.orig/tests/compat/server.test0000644000000000000000000002211012046313166015407 0ustar # # server.test # # Test for deprecated TclX server commands. Some tests will be skipped if we # are not on a known development machine, due to difficutly in certain # environments. Set the environment variable TCLX_FULL_TESTS to override. #------------------------------------------------------------------------------ # Copyright 1992-1999 Karl Lehenbauer and Mark Diekhans. # # Permission to use, copy, modify, and distribute this software and its # documentation for any purpose and without fee is hereby granted, provided # that the above copyright notice appear in all copies. Karl Lehenbauer and # Mark Diekhans make no representations about the suitability of this # software for any purpose. It is provided "as is" without express or # implied warranty. #------------------------------------------------------------------------------ # $Id: server.test,v 1.1 2001/10/24 23:31:49 hobbs Exp $ #------------------------------------------------------------------------------ # if [cequal [info procs Test] {}] {source testlib.tcl} eval $SAVED_UNKNOWN if [cequal $tcl_platform(platform) windows] { echo " * The server tests have not been ported to Win32" return } # # Determine if we are at a development site we know is good. If we are, we # do more checking. # switch -glob -- [id host] { {*.neosoft.com} {set safeHost 1} {*.grizzly.com} {set safeHost 1} default {set safeHost 0} } if [info exists env(TCLX_FULL_TESTS)] { set safeHost 1 } # # Test simple interaction with the echo server. This proc is used to # do the actual interaction. The server is connected to using various # different options and the same interaction done. # proc TalkToEcho {testId readFH writeFH buffered} { # Try gets/puts first. fconfigure $readFH -translation binary fconfigure $writeFH -translation binary Test $testId.1 {simple client interaction} { puts $writeFH "Test #1" if $buffered { flush $writeFH } list [gets $readFH result] $result } 0 {7 {Test #1}} # Queue serveral messages on buffered access if $buffered { Test $testId.2 {simple client interaction} { puts $writeFH "Test #2" puts $writeFH "Test #3" puts $writeFH "Test #4" puts $writeFH "Test #5" puts $writeFH "Test #6" puts $writeFH "Test #7" flush $writeFH list [gets $readFH] [gets $readFH] [gets $readFH] \ [gets $readFH] [gets $readFH] [gets $readFH] } 0 [list {Test #2} {Test #3} {Test #4} \ {Test #5} {Test #6} {Test #7}] } Test $testId.3 {simple client interaction} { puts $writeFH "Test #8" flush $writeFH list [gets $readFH result] $result } 0 {7 {Test #8}} Test $testId.4 {simple client interaction} { puts $writeFH "Test #9" flush $writeFH read $readFH 8 } 0 "Test #9\n" Test $testId.5 {simple client interaction} { puts -nonewline $writeFH "Test #10" flush $writeFH read $readFH 8 } 0 {Test #10} # Make sure we can dup a socket. Test $testId.6 {dup of a server connection} { set write2FH [dup $writeFH] if {"$readFH" != "$writeFH"} { set read2FH [dup $readFH] } else { set read2FH $write2FH } puts $write2FH "Test #11" flush $write2FH set stat [gets $read2FH result] close $write2FH if ![cequal $readFH $writeFH] { close $read2FH } list $stat $result } 0 {8 {Test #11}} # Try dup to stdin/stdout. Skip under Tk, as fork with out exec will # not work. if [lempty [info commands button]] { flush stdout flush stderr if {[set pid [fork]] == 0} { catch { Test $testId.8 {dup of a server connection} { dup $readFH stdin dup $writeFH stdout close $writeFH if ![cequal $readFH $writeFH] { close $readFH } puts stdout "Test #12" flush stdout list [gets stdin result] $result } 0 {8 {Test #12}} } exit 0 } wait $pid } # Test some of the fcntl options against a socket. Test $testId.9 {fcntl on a server connection} { fcntl $readFH NOBUF } 0 [expr !$buffered] Test $testId.10 {fcntl on a server connection} { fcntl $writeFH NOBUF } 0 [expr !$buffered] if $buffered { Test $testId.11 {fcntl on a server connection} { # This will hang and get alarm if buffered alarm 120 fcntl $writeFH NOBUF 1 puts $writeFH "Test #13" set stat [gets $readFH result] alarm 0 list $stat $result } 0 {8 {Test #13}} } Test $testId.12 {fcntl on a server connection} { fcntl $writeFH READ } 0 1 Test $testId.13 {fcntl on a server connection} { fcntl $writeFH WRITE } 0 1 # Test server_cntl on the socket. Test $testId.20 {server_cntl on a server connection} { server_cntl $writeFH KEEPALIVE 1 server_cntl $writeFH KEEPALIVE } 0 1 Test $testId.21 {server_cntl on a server connection} { server_cntl $writeFH KEEPALIVE 0 server_cntl $writeFH KEEPALIVE } 0 0 Test $testId.22 {server_send compatibility procs} { set all {} server_send $writeFH "Test 22.1" lappend all [gets $readFH result] $result server_send -nonewline $writeFH "Test 22.2\n" lappend all [gets $readFH result] $result set all } 0 {9 {Test 22.1} 9 {Test 22.2}} close $readFH if ![cequal $readFH $writeFH] { close $writeFH } return } # We might have trouble converting a hostname to IP address. If we can't, # just use the hostname to access. if $safeHost { set maybeIP [lindex [host_info addresses [id host]] 0] } else { set maybeIP [id host] catch { set maybeIP [lindex [host_info addresses [id host]] 0] } } # If we can't connect to the echo server, then skip these tests. if [catch { close [server_connect [id host] echo] } msg] { puts "*************************************************************" puts "Unable to connect to the \"echo\" server:" puts "$msg." puts "Some tests skipped." puts "*************************************************************" } else { Test server-8.1 {simple client interaction} { set fh [server_connect [id host] echo] TalkToEcho server-8.1 $fh $fh 1 } 0 {} Test server-8.2 {simple client interaction} { set ip [lindex [host_info addresses [id host]] 0] set fh [server_connect -nobuf $maybeIP echo] TalkToEcho server-8.2 $fh $fh 0 } 0 {} Test server-8.3 {simple client interaction} { set fh [server_connect -buf $maybeIP echo] TalkToEcho server-8.3 $fh $fh 1 } 0 {} Test server-8.4 {simple client interaction with compatibility interface} { set fhs [server_open -buf $maybeIP echo] TalkToEcho server-8.4 [lindex $fhs 0] [lindex $fhs 1] 1 } 0 {} } # # Fork a server to echo slightly modified versions of the messages. # proc TestServer {toClient} { signal ignore SIGPIPE set reqFH [server_create] fconfigure $toClient -buffering line puts $toClient [lindex [fstat $reqFH localhost] 2] set readIds $reqFH while 1 { set ready [lindex [select $readIds] 0] foreach id $ready { if [cequal $id $reqFH] { lappend readIds [server_accept -nobuf $reqFH] continue } if {[gets $id data] < 0} { set idx [lsearch -exact $readIds $id] set readIds [lreplace $readIds $idx $idx] continue } if [cequal $data EXIT] { exit } puts $id "Got \"$data\"" } } } pipe fromServer toClient flush stdout flush stderr if {[set serverPID [fork]] == 0} { catch { close $fromServer TestServer $toClient exit 0 } global errorInfo puts stderr "Error in test server: $errorInfo" exit 1 } close $toClient if {[gets $fromServer serverPort] < 0} { error "Unexpected EOF from test server" } close $fromServer Test server-9.1 {Tcl server} { set fh [server_connect -nobuf localhost $serverPort] puts $fh "Hello" set data [gets $fh] close $fh set data } 0 {Got "Hello"} Test server-9.2 {Tcl server} { set fh [server_connect -nobuf localhost $serverPort] puts $fh "Are you still there?" set data [list [gets $fh]] puts $fh "Are you really still there?" lappend data [gets $fh] close $fh set data } 0 {{Got "Are you still there?"} {Got "Are you really still there?"}} Test server-9.3 {Tcl server} { set fh [server_connect -nobuf localhost $serverPort] puts $fh "EXIT" lrange [wait $serverPID] 1 2 } 0 {EXIT 0} rename unknown {} tclx8.4-8.4.1.orig/tests/compat/copyfile.test0000644000000000000000000001035612046313166015724 0ustar # # copyfile.test # # Tests for the copyfile command. #--------------------------------------------------------------------------- # Copyright 1992-1999 Karl Lehenbauer and Mark Diekhans. # # Permission to use, copy, modify, and distribute this software and its # documentation for any purpose and without fee is hereby granted, provided # that the above copyright notice appear in all copies. Karl Lehenbauer and # Mark Diekhans make no representations about the suitability of this # software for any purpose. It is provided "as is" without express or # implied warranty. #------------------------------------------------------------------------------ # $Id: copyfile.test,v 1.1 2001/10/24 23:31:49 hobbs Exp $ #------------------------------------------------------------------------------ # if [cequal [info procs Test] {}] {source testlib.tcl} eval $SAVED_UNKNOWN # # Compare the contents of two files. Return 1 if the same, 0 if different. # proc TestCompareFiles {fn1 fn2} { set fh1 [open $fn1] fconfigure $fh1 -translation binary set data1 [read $fh1] close $fh1 set fh2 [open $fn2] fconfigure $fh2 -translation binary set data2 [read $fh2] close $fh2 return [cequal $data1 $data2] } # Create a test file TestRemove COPYFILE1.TMP COPYFILE2.TMP COPYFILE3.TMP set testFH [open COPYFILE1.TMP w] set testFileSize 0 for {set cnt 0} {$cnt < 100} {incr cnt} { set rec [GenRec $cnt] puts $testFH $rec incr testFileSize [expr [clength $rec]+1] if [cequal $tcl_platform(platform) windows] { incr testFileSize ;# for } } close $testFH if {$testFileSize != [file size COPYFILE1.TMP]} { error "Wrong file size calculated for COPYFILE1.TMP" } Test copyfile-1.1 {copyfile tests} { set testFH1 [open COPYFILE1.TMP r] set testFH2 [open COPYFILE2.TMP w] copyfile $testFH1 $testFH2 close $testFH1 close $testFH2 TestCompareFiles COPYFILE1.TMP COPYFILE2.TMP } 0 1 Test copyfile-1.1.1 {copyfile tests} { # Source/target open read-write. set testFH [open COPYFILE1.TMP r+] set testFH2 [open COPYFILE2.TMP r+] seek $testFH2 0 copyfile $testFH $testFH2 close $testFH close $testFH2 TestCompareFiles COPYFILE1.TMP COPYFILE2.TMP } 0 1 Test copyfile-1.2 {copyfile tests} { set testFH [open COPYFILE3.TMP w] set testFH2 [open COPYFILE2.TMP w] set stat [list [catch {copyfile $testFH $testFH2} msg] \ [lrange $msg 2 end]] close $testFH close $testFH2 set stat } 0 {1 {wasn't opened for reading}} Test copyfile-1.3 {copyfile tests} { set testFH [open COPYFILE1.TMP r] set testFH2 [open COPYFILE2.TMP r] set stat [list [catch {copyfile $testFH $testFH2} msg] \ [lrange $msg 2 end]] close $testFH close $testFH2 set stat } 0 {1 {wasn't opened for writing}} Test copyfile-1.4 {copyfile tests} { copyfile $testFH $testFH2 } 1 "can not find channel named \"$testFH\"" Test copyfile-1.5 {copyfile tests} { copyfile } 1 {wrong # args: copyfile ?-bytes num|-maxbytes num? ?-translate? fromFileId toFileId} foreach flag {-bytes -maxbytes} { Test copyfile-1.6.$flag {copyfile tests} { set copySize [expr ($testFileSize*2)/3] set testFH [open COPYFILE1.TMP r] set testFH2 [open COPYFILE2.TMP w] copyfile $flag $copySize $testFH $testFH2 close $testFH close $testFH2 list [expr [file size COPYFILE2.TMP] == $copySize] \ [TestCompareFiles COPYFILE1.TMP COPYFILE2.TMP] } 0 {1 0} catch {unset testData testData2} } set copySize [expr $testFileSize*2] Test copyfile-1.7 {copyfile tests} { set testFH [open COPYFILE1.TMP r] set testFH2 [open COPYFILE2.TMP w] set stat [catch {copyfile -bytes $copySize $testFH $testFH2} msg] close $testFH close $testFH2 list $stat $msg } 0 [list 1 \ "premature EOF, $copySize bytes expected, $testFileSize bytes actually read"] Test copyfile-1.7 {copyfile tests} { set testFH [open COPYFILE1.TMP r] set testFH2 [open COPYFILE2.TMP w] set stat [catch {copyfile -maxbytes $copySize $testFH $testFH2} msg] close $testFH close $testFH2 list $stat $msg } 0 [list 0 $testFileSize] TestRemove COPYFILE1.TMP COPYFILE2.TMP COPYFILE3.TMP rename unknown {} tclx8.4-8.4.1.orig/tests/compat/file.test0000644000000000000000000001151612046313167015031 0ustar # # file.test # # Tests for deprecated TclX file commands: mkdir, rmdir, unlink, frename. #--------------------------------------------------------------------------- # Copyright 1992-1999 Karl Lehenbauer and Mark Diekhans. # # Permission to use, copy, modify, and distribute this software and its # documentation for any purpose and without fee is hereby granted, provided # that the above copyright notice appear in all copies. Karl Lehenbauer and # Mark Diekhans make no representations about the suitability of this # software for any purpose. It is provided "as is" without express or # implied warranty. #------------------------------------------------------------------------------ # $Id: file.test,v 1.1 2001/10/24 23:31:49 hobbs Exp $ #------------------------------------------------------------------------------ # if [cequal [info procs Test] {}] {source testlib.tcl} eval $SAVED_UNKNOWN TestRemove MKDIR1.TMP MKDIR2.TMP MKDIR3.TMP UNLINK1.TMP UNLINK2.TMP \ UNLINK3.TMP FRENAME1.TMP FRENAME2.TMP Test file-compat-1.1 {mkdir tests} { catch {rmdir {MKDIR1.TMP MKDIR2.TMP}} mkdir {MKDIR1.TMP MKDIR2.TMP} set result [list [file isdirectory MKDIR1.TMP] \ [file isdirectory MKDIR2.TMP]] catch {rmdir {MKDIR1.TMP MKDIR2.TMP}} set result } 0 {1 1} Test file-compat-1.2 {mkdir tests} { catch {rmdir {MKDIR1.TMP/a/b/c MKDIR1.TMP/a/b MKDIR1.TMP/a MKDIR1.TMP}} mkdir -path MKDIR1.TMP/a/b/c set result [file isdirectory MKDIR1.TMP/a/b/c] catch {rmdir {MKDIR1.TMP/a/b/c MKDIR1.TMP/a/b MKDIR1.TMP/a MKDIR1.TMP}} set result } 0 1 Test file-compat-1.3 {mkdir tests} { catch {rmdir {MKDIR1.TMP/a/b/c MKDIR1.TMP/a/b MKDIR1.TMP/a MKDIR1.TMP}} mkdir -path MKDIR1.TMP/a/b/c mkdir -path MKDIR1.TMP/a/b/c set result [file isdirectory MKDIR1.TMP/a/b/c] catch {rmdir {MKDIR1.TMP/a/b/c MKDIR1.TMP/a/b MKDIR1.TMP/a MKDIR1.TMP}} set result } 0 1 Test file-compat-1.4 {mkdir tests} { catch {mkdir MKDIR1.TMP} set result [list [catch {mkdir MKDIR1.TMP} msg] [string tolower $msg]] catch {rmdir MKDIR1.TMP} set result } 0 {1 {creating directory "mkdir1.tmp" failed: file already exists}} Test file-compat-1.5 {mkdir tests} { catch {mkdir MKDIR1.TMP} close [open MKDIR1.TMP/notAdir w] set result [list [catch {mkdir -path MKDIR1.TMP/notAdir} msg] \ [string tolower $msg]] unlink MKDIR1.TMP/notAdir catch {rmdir MKDIR1.TMP} set result } 0 {1 {creating directory "mkdir1.tmp/notadir" failed: file already exists}} Test file-compat-2.1 {rmdir tests} { catch {mkdir {MKDIR1.TMP MKDIR2.TMP}} rmdir {MKDIR1.TMP MKDIR2.TMP} list [file isdirectory MKDIR1.TMP] [file isdirectory MKDIR2.TMP] } 0 {0 0} Test file-compat-2.2 {rmdir tests} { catch {rmdir MKDIR1.TMP} list [catch {rmdir MKDIR1.TMP} msg] [string tolower $msg] } 0 {1 {can't remove "mkdir1.tmp": no such file or directory}} Test file-compat-2.3 {rmdir tests} { catch {rmdir MKDIR1.TMP} list [catch {rmdir MKDIR1.TMP} msg] [string tolower $msg] } 0 {1 {can't remove "mkdir1.tmp": no such file or directory}} Test file-compat-2.4 {rmdir tests} { close [open MKDIR3.TMP w] list [catch {rmdir MKDIR3.TMP} msg] [string tolower $msg] } 0 {1 {mkdir3.tmp: not a directory}} Test file-compat-2.5 {rmdir tests} { catch {rmdir MKDIR1.TMP} rmdir -nocomplain MKDIR1.TMP } 0 {} Test file-compat-3.1 {unlink tests} { set fh [open UNLINK1.TMP w] puts $fh "Hello, world" close $fh unlink UNLINK1.TMP file exists UNLINK1.TMP } 0 0 Test file-compat-3.2 {unlink tests} { list [catch {unlink UNLINK1.TMP} msg] [string tolower $msg] } 0 {1 {can't remove "unlink1.tmp": no such file or directory}} Test file-compat-3.4 {unlink tests} { set fh [open UNLINK1.TMP w] puts $fh "Hello, world" close $fh unlink -nocomplain {../src/FOOWAPFOO UNLINK1.TMP} file exists UNLINK1.TMP } 0 0 Test file-compat-3.4 {unlink tests} { mkdir UNLINK2.TMP link -sym UNLINK2.TMP UNLINK3.TMP unlink UNLINK3.TMP catch {file readlink UNLINK3.TMP} } 0 1 {unixOnly} Test file-compat-3.5 {unlink tests} { link -sym UNLINK100.TMP UNLINK3.TMP unlink UNLINK3.TMP catch {file readlink UNLINK3.TMP} } 0 1 {unixOnly} Test file-compat-4.1 {frename tests} { close [open FRENAME1.TMP w] set result [file exists FRENAME1.TMP] lappend result [file exists FRENAME2.TMP] frename FRENAME1.TMP FRENAME2.TMP lappend result [file exists FRENAME1.TMP] lappend result [file exists FRENAME2.TMP] set result } 0 {1 0 0 1} Test file-compat-4.4 {frename tests} { TestRemove FRENAME3.TMP list [catch {frename FRENAME3.TMP FRENAME4.TMP} msg] [string tolower $msg] } 0 {1 {error renaming "frename3.tmp": no such file or directory}} TestRemove MKDIR1.TMP MKDIR2.TMP MKDIR3.TMP UNLINK1.TMP UNLINK2.TMP \ UNLINK3.TMP FRENAME1.TMP FRENAME2.TMP rename unknown {} tclx8.4-8.4.1.orig/tests/arrayproc.test0000644000000000000000000000452712046313167014635 0ustar # # arrayproc.test # # Tests for tcl.tlib array routines. #--------------------------------------------------------------------------- # Copyright 1992-1999 Karl Lehenbauer and Mark Diekhans. # # Permission to use, copy, modify, and distribute this software and its # documentation for any purpose and without fee is hereby granted, provided # that the above copyright notice appear in all copies. Karl Lehenbauer and # Mark Diekhans make no representations about the suitability of this # software for any purpose. It is provided "as is" without express or # implied warranty. #------------------------------------------------------------------------------ # $Id: arrayproc.test,v 1.2 2002/04/02 02:29:43 hobbs Exp $ #------------------------------------------------------------------------------ # if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import ::tcltest::* } package require Tclx 8.4 set testArray(foo) bar set testArray(snap) frammistan set testArray(0) zero set testArray(william) dafoe test for_array_keys-1.1 {for_array_keys command} { for_array_keys key testArray { lappend result $key } lsort $result } "0 foo snap william" test for_array_keys-1.2 {errors in for_array_keys command} { list [catch { for_array_keys key testArray { error fakeResult fakeInfo fakeCode } } msg] $msg [crange $errorInfo 0 7] $errorCode } {1 fakeResult fakeInfo fakeCode} test for_array_keys-1.3 {break in for_array_keys command} { set cnt 0 list [catch { for_array_keys key testArray { incr cnt break } } msg] $msg $cnt } {0 {} 1} test for_array_keys-1.4 {break in for_array_keys command} { set cnt 0 list [catch { for_array_keys key testArray { incr cnt continue incr cnt 20 } } msg] $msg $cnt } {0 {} 4} test for_array_keys-1.5 {return in for_array_keys command} { proc for_array_keys_test {testArrayVar cntVar} { upvar $testArrayVar testArray $cntVar cnt for_array_keys key testArray { incr cnt return abcd } } set cnt 0 list [catch {for_array_keys_test testArray cnt} msg] $msg $cnt } {0 abcd 1} rename for_array_keys_test {} unset testArray unset result # cleanup ::tcltest::cleanupTests return tclx8.4-8.4.1.orig/tests/list.test0000644000000000000000000001404412046313166013600 0ustar # # list.test # # Tests for the lvarpop command. #--------------------------------------------------------------------------- # Copyright 1992-1999 Karl Lehenbauer and Mark Diekhans. # # Permission to use, copy, modify, and distribute this software and its # documentation for any purpose and without fee is hereby granted, provided # that the above copyright notice appear in all copies. Karl Lehenbauer and # Mark Diekhans make no representations about the suitability of this # software for any purpose. It is provided "as is" without express or # implied warranty. #------------------------------------------------------------------------------ # $Id: list.test,v 1.2 2002/04/02 02:29:43 hobbs Exp $ #------------------------------------------------------------------------------ # if {[cequal [info procs Test] {}]} { source [file join [file dirname [info script]] testlib.tcl] } Test list-1.1 {lvarpop tests} { set a {a b c d e f g h i j} list [lvarpop a 0] $a } 0 {a {b c d e f g h i j}} Test list-1.2 {lvarpop tests} { set a {a bbbbbb c d e f g h i j} list [lvarpop a 1] $a } 0 {bbbbbb {a c d e f g h i j}} Test list-1.3 {lvarpop tests} { set a {a bbbbbb c d e f g h i j} list [lvarpop a 4] $a } 0 {e {a bbbbbb c d f g h i j}} Test list-1.3.1 {lvarpop tests} { set a {a bbbbbb c d e f g h i j} list [lvarpop a end] $a } 0 {j {a bbbbbb c d e f g h i}} Test list-1.3.2 {lvarpop tests} { set a {a bbbbbb c d e f g h i j} list [lvarpop a end-1] $a } 0 {i {a bbbbbb c d e f g h j}} Test list-1.4 {lvarpop tests} { set a {a bbbbbb c d e f g h i j} list [lvarpop a 2 frobozz] $a } 0 {c {a bbbbbb frobozz d e f g h i j}} Test list-1.4.1 {lvarpop tests} { set a {a bbbbbb c d e f g h i j} list [lvarpop a end frobozz] $a } 0 {j {a bbbbbb c d e f g h i frobozz}} Test list-1.4.2 {lvarpop tests} { set a {a bbbbbb c d e f g h i j} list [lvarpop a end-1 frobozz] $a } 0 {i {a bbbbbb c d e f g h frobozz j}} Test list-1.5 {lvarpop tests} { set a {a bbbbbb frozbozz d e f g h i j} list [lvarpop a 2 f] $a } 0 {frozbozz {a bbbbbb f d e f g h i j}} Test list-1.6 {lvarpop tests} { set a {a bbbbbb c d e f g h i j} list [lvarpop a 20 frobozz] $a } 0 {{} {a bbbbbb c d e f g h i j}} Test list-1.7 {lvarpop tests} { set a {} list [lvarpop a] $a } 0 {{} {}} Test list-1.8 {lvarpop tests} { set a "a bbbbbb \{a" lvarpop a 2 frobozz } 1 {unmatched open brace in list} Test list-1.9 {lvarpop tests} { lvarpop } 1 {wrong # args: lvarpop var ?indexExpr? ?string?} Test list-1.10 {lvarpop tests} { unset a lvarpop a } 1 {can't read "a": no such variable} Test list-2.1 {lvarpush tests} { set a {a b c d e f g h i j} lvarpush a "xxx" set a } 0 {xxx a b c d e f g h i j} Test list-2.2 {lvarpush tests} { set a {a c d e f g h i j} lvarpush a b 1 set a } 0 {a b c d e f g h i j} Test list-2.3 {lvarpush tests} { set a {a bbbbbb c d f g h i j} lvarpush a e 4 set a } 0 {a bbbbbb c d e f g h i j} Test list-2.4 {lvarpush tests} { set a {a bbbbbb c d e f g h i j} lvarpush a frobozz 2 set a } 0 {a bbbbbb frobozz c d e f g h i j} Test list-2.5 {lvarpush tests} { set a {a b c d} lvarpush a e 4 set a } 0 {a b c d e} Test list-2.6 {lvarpush tests} { set a {a b c d} lvarpush a e 4 set a } 0 {a b c d e} Test list-2.7 {lvarpush tests} { set a {a b c d} lvarpush a e 14 set a } 0 {a b c d e} Test list-2.7.1 {lvarpush tests} { set a {a b c d} lvarpush a e end set a } 0 {a b c e d} Test list-2.7.2 {lvarpush tests} { set a {a b c d} lvarpush a e end+1 set a } 0 {a b c d e} Test list-2.7.3 {lvarpush tests} { set a {a b c d} lvarpush a e end-1 set a } 0 {a b e c d} Test list-2.8 {lvarpush tests} { set a "a bbbbbb \{a" lvarpush a 2 frobozz } 1 {unmatched open brace in list} Test list-2.9 {lvarpush tests} { set a {} lvarpush a a set a } 0 {a} Test list-2.10 {lvarpush tests} { unset a lvarpush a a set a } 0 {a} Test list-2.11 {lvarpush tests} { set a "a bbbbbb \{a" lvarpush a 2 frobozz } 1 {unmatched open brace in list} Test list-2.12 {lvarpush tests} { lvarpush } 1 {wrong # args: lvarpush var string ?indexExpr?} Test list-3.1 {lvarcat} { unset a lvarcat a a b c d e f g set a } 0 {a b c d e f g} Test list-3.2 {lvarcat} { unset a lvarcat a a b c d e f g } 0 {a b c d e f g} Test list-3.3 {lvarcat} { unset a lvarcat a a {b c d} {e f g h} set a } 0 {a b c d e f g h} Test list-3.4 {lvarcat} { unset a lvarcat a a {b c d} {e f g h} } 0 {a b c d e f g h} Test list-3.5 {lvarcat} { unset a lvarcat a a {b {c d}} lvarcat a {{e f}} g h set a } 0 {a b {c d} {e f} g h} Test list-3.6 {lvarcat} { unset a lvarcat a a\{ {b \{c d} \{d set a } 0 "a{ b \\{c d {d" Test list-3.7 {lvarcat} { lvarcat a } 1 {wrong # args: lvarcat var string ?string...?} Test list-3.8 {lvarcat} { lvarcat } 1 {wrong # args: lvarcat var string ?string...?} Test list-4.1 {lcontain} { lcontain } 1 {wrong # args: lcontain list element} Test list-4.2 {lcontain} { lcontain a b c } 1 {wrong # args: lcontain list element} Test list-4.3 {lcontain} { lcontain {aaaa bbbb cccc} aaaa } 0 1 Test list-4.4 {lcontain} { lcontain {aaaa bbbb cccc} a } 0 0 Test list-4.5 {lcontain} { lcontain [list a\0\0a bbbb cccc] a\0\0a } 0 1 Test list-4.6 {lcontain} { lcontain [list a\0aaa bbbb cccc] a } 0 0 Test list-4.7 {lcontain} { # Strings of same length lcontain {SEEKABLE} SEEKABLE } 0 1 Test list-5.1 {lempty} { lempty {} } 0 1 Test list-5.2 {lempty} { lempty "\t" } 0 1 Test list-5.3 {lempty} { lempty "\tx" } 0 0 Test list-5.4 {lempty} { # lempty doesn't check for a valid list. lempty { {X}xx} } 0 0 Test list-5.5 {lempty} { lempty } 1 {wrong # args: lempty list} Test list-5.6 {lempty} { lempty x y } 1 {wrong # args: lempty list} Test list-5.7 {lempty} { lempty "\0" } 0 0 Test list-5.8 {lempty} { lempty " \0x" } 0 0 # cleanup ::tcltest::cleanupTests return tclx8.4-8.4.1.orig/tests/tcllib.test0000644000000000000000000002402612046313166014077 0ustar # # tcllib.test # # Tests for commands and functionality involved in demand loadable Tcl # libraries. #--------------------------------------------------------------------------- # Copyright 1992-1999 Karl Lehenbauer and Mark Diekhans. # # Permission to use, copy, modify, and distribute this software and its # documentation for any purpose and without fee is hereby granted, provided # that the above copyright notice appear in all copies. Karl Lehenbauer and # Mark Diekhans make no representations about the suitability of this # software for any purpose. It is provided "as is" without express or # implied warranty. #------------------------------------------------------------------------------ # $Id: tcllib.test,v 1.5 2002/09/26 00:23:30 hobbs Exp $ #------------------------------------------------------------------------------ # if {[cequal [info procs Test] {}]} { source [file join [file dirname [info script]] testlib.tcl] } auto_load auto_reset ;# Make sure we have this before changing path. global save_auto_path auto_path set save_auto_path $auto_path set auto_path {} catch {unset auto_path} # # Test library directories. # if ![file isdirectory tcllib1.dir] { file mkdir tcllib1.dir } if ![file isdirectory tcllib2.dir] { file mkdir tcllib2.dir } # # Since we have libraries coming and going in this test, we need to # reset the environment. # proc TclLibReset {} { auto_reset catch {unset auto_pkg_index} } # proc TclLibCleanUp {} { if [file exists tcllib1.dir] { chmod u=wrx tcllib1.dir eval TestRemove [glob -nocomplain tcllib1.dir/*] } if [file exists tcllib2.dir] { chmod u=wrx tcllib2.dir eval TestRemove [glob -nocomplain tcllib2.dir/*] } TclLibReset } TclLibCleanUp proc PutFile {fileName args} { set fp [open $fileName w] foreach line $args { puts $fp $line } close $fp } catch {rename buildpackageindex {}} ;# Make sure we can autoload this # # Test parameter checking for the basic commands that are implemented # in C. # test tcllib-1.2 {command parameter checking} { list [catch {loadlibindex} msg] $msg } {1 {wrong # args: loadlibindex libFile}} test tcllib-1.3 {command parameter checking} { list [catch {loadlibindex a b c d} msg] $msg } {1 {wrong # args: loadlibindex libFile}} # # Test error recovery from bogus paths (should ignore path and not find proc) # test tcllib-2.1 {bogus path test} { set auto_path [list /bogus/dir/path/no/work $tclx_library] list [catch {TclLibAAA} msg] $msg } {1 {invalid command name "TclLibAAA"}} #catch {rename buildpackageindex {}} ;# Make sure we can autoload this test tcllib-2.2 {bogus path test} { set auto_path [list ~bogususerman/tcllib $tclx_library] list [catch {TclLibAAA} msg] $msg } {1 {invalid command name "TclLibAAA"}} test tcllib-2.3 {bogus path test} { set auto_path $tclx_library set auto_path [list /bogus/dir/path/no/work] list [catch {TclLibAAA} msg] $msg } {1 {invalid command name "TclLibAAA"}} # # Test error recovery from bogus package library indices. # proc BuildTestLib {name {pbase TclLibAA}} { PutFile $name \ "#@package: $name-package ${pbase}B ${pbase}C ${pbase}D" \ "proc ${pbase}B {} {return \"***${pbase}B***\"}" \ "proc ${pbase}C {} {return \"***${pbase}C***\"}" \ "proc ${pbase}D {} {return \"***${pbase}D***\"}" \ "#@packend" } BuildTestLib tcllib1.dir/test1.tlib PutFile tcllib1.dir/test1.tndx {bogus data} TclLibReset set auto_path [list [pwd]/tcllib1.dir $tclx_library] test tcllib-3.1 {bogus package library index} { set re {(error while autoloading "TclLibAAB": )?format error in library index "....+test1.tndx" \(bogus\)$} list [catch {TclLibAAB} msg] [expr {[regexp $re $msg]?1:$msg}] } {1 1} catch {rename buildpackageindex {}} ;# Make sure we can autoload this PutFile tcllib1.dir/test1.tndx \ {test1-package 56 240 TclLibAAB TclLibAAC TclLibAAD} TclLibReset test tcllib-3.2 {bogus package library index} { set re {^(error while autoloading "TclLibAAB": )?range to eval outside of file bounds in "....+test1.tlib", index file probably corrupt$} list [catch {TclLibAAB} msg] [expr {[regexp $re $msg]?1:$msg}] } {1 1} PutFile tcllib1.dir/test1.tndx \ {test1-package -1 140 TclLibAAB TclLibAAC TclLibAAD} TclLibReset test tcllib-3.3 {bogus package library index} { set re {^(error while autoloading "TclLibAAB": )?format error in library index ".*" \(test1-package -1 140 TclLibAAB TclLibAAC TclLibAAD\)$} list [catch {TclLibAAB} msg] [expr {[regexp $re $msg]?1:$msg}] } {1 1} catch {rename buildpackageindex {}} ;# Make sure we can autoload this PutFile tcllib1.dir/test1.tndx \ {test1-package 456 40 TclLibAAB TclLibAAC TclLibAAD} TclLibReset test tcllib-3.4 {bogus package library index} { set re {^(error while autoloading "TclLibAAB": )?range to eval outside of file bounds in "...+test1.tlib", index file probably corrupt} list [catch {TclLibAAB} msg] [expr {[regexp $re $msg]?1:$msg}] } {1 1} TclLibReset set auto_path [list [pwd]/tcllib2.dir $tclx_library] test tcllib-4.1 {bad rebuild package library index} {isNotRoot && need_chmod} { BuildTestLib tcllib2.dir/test1.tlib TclLibAB chmod -w tcllib2.dir set re {^(error while autoloading "tcllibabb": )?building package index for.*/tcllib2.dir/test1.tlib' failed: couldn't open ".*/tcllib2.dir/test1.tndx": permission denied$} list [catch {TclLibABB} msg] [expr {[regexp $re $msg]?1:$msg}] } {1 1} TclLibCleanUp set auto_path [list [pwd]/tcllib1.dir $tclx_library] PutFile tcllib1.dir/tclIndex "#" "badline" "nukearray nukearray.tmp" \ "baz baz.tmp" test tcllib-5.1 {bogus Ousterhout library index} { set stat [catch nukearray msg] if {[string match "*/tclIndex isn't a proper Tcl index file" $msg]} { list $stat {IS OK} } else { list $stat $msg } } {1 {IS OK}} PutFile tcllib1.dir/tclIndex "# Tcl autoload index file, version 2.0" \ {set auto_index(parray) " source [file join $dir parray.tcl]"} \ {set auto_index(nukearray) "source [file join $dir spazzzzzzzz]"} \ test tcllib-5.2 {missing file found with Ousterhout library index} { list [catch {nukearray} msg] $msg } {1 {invalid command name "nukearray"}} test tcllib-5.3 {missing file found with Ousterhout library index} \ {isNotRoot && need_chmod} { PutFile tcllib1.dir/nukearray.tmp {proc nukearray {} {}} chmod 000 tcllib1.dir/nukearray.tmp list [catch {nukearray} msg] $msg } {1 {invalid command name "nukearray"}} TclLibCleanUp BuildTestLib tcllib1.dir/test2.tlib TclLibAC set auto_path [list [pwd]/tcllib1.dir $tclx_library] PutFile tcllib1.dir/tclIndex "# Tcl autoload index file, version 2.0" \ {set auto_index(parray) " source [file join $dir parray.tcl]"} \ {set auto_index(nukearray) "source [file join $dir nukearray.tmp]"} PutFile tcllib1.dir/nukearray.tmp {proc nukearray {} {return "@nukearray@"}} test tcllib-6.1 {successful library access} { TclLibACB } {***TclLibACB***} test tcllib-6.2 {successful library access} { TclLibACB } {***TclLibACB***} test tcllib-6.3 {successful library access} { nukearray } {@nukearray@} # # Test skipping of duplicate packages. Also make sure loadlibindex overrides # existing package definitions. Test for both .tlib and tclIndex indexes. # TclLibCleanUp set auto_path [list [pwd]/tcllib1.dir [pwd]/tcllib2.dir $tclx_library] PutFile tcllib1.dir/test1.tlib \ {#@package: test-pkg DupPkgTest} \ {proc DupPkgTest {} {return {Version-1}} } PutFile tcllib2.dir/test2.tlib \ {#@package: test-pkg DupPkgTest} \ {proc DupPkgTest {} {return {Version-2}} } test tcllib-7.1 {Duplicate package handling} { DupPkgTest } {Version-1} TclLibReset test tcllib-7.2 {Duplicate package handling} { lrmdups {a b c} ;# Force load of indices. loadlibindex tcllib2.dir/test2.tlib DupPkgTest } {Version-2} TclLibCleanUp set auto_path [list [pwd]/tcllib1.dir [pwd]/tcllib2.dir $tclx_library] PutFile tcllib1.dir/tclIndex "# Tcl autoload index file, version 2.0" \ {set auto_index(DupPkgTest) " source [file join $dir test1.tcl]"} PutFile tcllib1.dir/test1.tcl \ {proc DupPkgTest {} {return {Version-1}} } PutFile tcllib2.dir/tclIndex "# Tcl autoload index file, version 2.0" \ {set auto_index(DupPkgTest) " source [file join $dir test1.tcl]"} PutFile tcllib2.dir/test1.tcl \ {proc DupPkgTest {} {return {Version-2}} } test tcllib-7.3 {Duplicate package handling} { DupPkgTest } {Version-1} TclLibReset # # Test backslash parsing in #@package: line. # TclLibCleanUp set auto_path [list [pwd]/tcllib1.dir [pwd]/tcllib2.dir $tclx_library] PutFile tcllib1.dir/test1.tlib \ "#@package: test-pkg procAAA \\" \ " procBBB \\" \ " procCCC" \ "proc procAAA {} {return {AAA}}" \ "proc procBBB {} {return {BBB}}" \ "proc procCCC {} {return {CCC}}" test tcllib-8.1 {backslash parsing in package headers} { TclLibReset procAAA } {AAA} test tcllib-8.2 {backslash parsing in package headers} { TclLibReset procBBB } {BBB} test tcllib-8.3 {backslash parsing in package headers} { TclLibReset procCCC } {CCC} TclLibCleanUp # # Test with namespaces. # proc BuildNSTestLib {name ns {pbase TclLibAA}} { PutFile $name \ "#@package: $name-package ::${ns}::${pbase}B ::${ns}::${pbase}C \ ::${ns}::${pbase}D" \ "namespace eval $ns {"\ " proc ${pbase}B {} {return \"***${ns}::${pbase}B***\"}" \ " proc ${pbase}C {} {return \"***${ns}::${pbase}C***\"}" \ " proc ${pbase}D {} {return \"\[${pbase}C\] ***${ns}::${pbase}D***\"}" \ "}" \ "#@packend" } BuildNSTestLib tcllib1.dir/test1.tlib TclXLibTest TclLibNS TclLibReset set auto_path [list [pwd]/tcllib1.dir $tclx_library] test tcllib-9.1 {successful library access} { TclXLibTest::TclLibNSB } {***TclXLibTest::TclLibNSB***} test tcllib-9.2 {successful library access} { TclXLibTest::TclLibNSB } {***TclXLibTest::TclLibNSB***} test tcllib-9.3 {successful library access} { TclXLibTest::TclLibNSD } {***TclXLibTest::TclLibNSC*** ***TclXLibTest::TclLibNSD***} TestRemove tcllib1.dir tcllib2.dir rename TclLibCleanUp {} rename PutFile {} rename TclLibReset {} set auto_path $save_auto_path # cleanup ::tcltest::cleanupTests return tclx8.4-8.4.1.orig/tests/setfuncs.test0000644000000000000000000001011012046313167014446 0ustar # # setfuncs.test # # Tests for tcl.tlib set functions. #--------------------------------------------------------------------------- # Copyright 1992-1999 Karl Lehenbauer and Mark Diekhans. # # Permission to use, copy, modify, and distribute this software and its # documentation for any purpose and without fee is hereby granted, provided # that the above copyright notice appear in all copies. Karl Lehenbauer and # Mark Diekhans make no representations about the suitability of this # software for any purpose. It is provided "as is" without express or # implied warranty. #------------------------------------------------------------------------------ # $Id: setfuncs.test,v 1.2 2002/04/02 02:29:43 hobbs Exp $ #------------------------------------------------------------------------------ # if {[cequal [info procs Test] {}]} { source [file join [file dirname [info script]] testlib.tcl] } Test setfuncs-1.1 {union command} { union "" "" } 0 "" Test setfuncs-1.2 {union command} { union a "" } 0 "a" Test setfuncs-1.3 {union command} { union "a b" "b c" } 0 "a b c" Test setfuncs-1.4 {union command} { union "a b c d" "a b c d" } 0 "a b c d" Test setfuncs-1.5 {union command} { union "a d c d b" "b d c a a b d a b c d" } 0 "a b c d" Test setfuncs-1.6 {union command} { union "d c b a e f" "" } 0 "a b c d e f" Test setfuncs-1.7 {union command} { union "" "f e d c b a" } 0 "a b c d e f" Test setfuncs-1.8 {union command} { union "{n p}" "f e d c b a" } 0 "a b c d e f {n p}" Test setfuncs-1.9 {union command} { union "{n p}" "f e d c {n p} b a" } 0 "a b c d e f {n p}" Test setfuncs-1.10 {union command} { union "{n p} z {n p} z" "f e d c {n p} b a" } 0 "a b c d e f {n p} z" Test setfuncs-2.1 {intersect command} { intersect "" "" } 0 "" Test setfuncs-2.2 {intersect command} { intersect "a b c" "" } 0 "" Test setfuncs-2.3 {intersect command} { intersect "" "a b c" } 0 "" Test setfuncs-2.4 {intersect command} { intersect "d f b" "a b c" } 0 "b" Test setfuncs-2.5 {intersect command} { intersect "a p q d v m b n o z t d f b" "a b c" } 0 "a b" Test setfuncs-2.6 {intersect command} { intersect "d c b a e f" "{n p}" } 0 "" Test setfuncs-2.7 {intersect command} { intersect "d c" "f e d c b a" } 0 "c d" Test setfuncs-2.8 {intersect command} { intersect "a f {n p} e" "f e d c b a" } 0 "a e f" Test setfuncs-2.9 {intersect command} { intersect "{n p} f d" "f e d c {n p} b a" } 0 "d f {n p}" Test setfuncs-2.10 {intersect command} { intersect "{n p} z {n p} z" "f e d c {n p} b a" } 0 "{n p}" Test setfuncs-3.1 {intersect3 command} { intersect3 "" "" } 0 "{} {} {}" Test setfuncs-3.2 {intersect3 command} { intersect3 "a b c" "" } 0 "{a b c} {} {}" Test setfuncs-3.3 {intersect3 command} { intersect3 "" "a b c" } 0 "{} {} {a b c}" Test setfuncs-3.4 {intersect3 command} { intersect3 "d f b" "a b c" } 0 "{d f} b {a c}" Test setfuncs-3.5 {intersect3 command} { intersect3 "a p q d v m b n o z t d f b" "a b c" } 0 "{d f m n o p q t v z} {a b} c" # Multiple elements in a list. Test setfuncs-3.6 {intersect3 command} { intersect3 {aa bb cc dd ee ff} {aa bb cc dd aa bb ee ff} } 0 {{} {aa bb cc dd ee ff} {}} Test setfuncs-3.7 {intersect3 command} { intersect3 {aa bb cc dd aa bb ee ff} {aa bb cc dd ee ff} } 0 {{} {aa bb cc dd ee ff} {}} Test setfuncs-3.8 {intersect3 command} { intersect3 {aa XX bb cc dd aa bb ee ff} {aa YY bb cc ZZ dd ee ff} } 0 {XX {aa bb cc dd ee ff} {YY ZZ}} Test setfuncs-3.9 {intersect3 command} { intersect3 {aa YY bb cc ZZ dd ee ff} {aa XX bb cc dd aa bb ee ff} } 0 {{YY ZZ} {aa bb cc dd ee ff} XX} Test setfuncs-4.1 {lrmdups command} { lrmdups {a d b c eee b d 1} } 0 {1 a b c d eee} Test setfuncs-4.2 {lrmdups command} { lrmdups {aaa aaa aaaa aaa aaa } } 0 {aaa aaaa} Test setfuncs-4.3 {lrmdups command} { lrmdups {{} aaa {} aaa aaa } } 0 {{} aaa} Test setfuncs-4.4 {lrmdups command} { lrmdups {aaa} } 0 {aaa} Test setfuncs-4.5 {lrmdups command} { lrmdups [list {ma mb} {mc md} {ma mb}] } 0 {{ma mb} {mc md}} # cleanup ::tcltest::cleanupTests return tclx8.4-8.4.1.orig/tests/globrecur.test0000644000000000000000000001357312046313167014620 0ustar # # globrecur.test # # Tests for recursive_glob and for_recursive_globs procedures. # #--------------------------------------------------------------------------- # Copyright 1992-1999 Karl Lehenbauer and Mark Diekhans. # # Permission to use, copy, modify, and distribute this software and its # documentation for any purpose and without fee is hereby granted, provided # that the above copyright notice appear in all copies. Karl Lehenbauer and # Mark Diekhans make no representations about the suitability of this # software for any purpose. It is provided "as is" without express or # implied warranty. #------------------------------------------------------------------------------ # $Id: globrecur.test,v 1.2 2002/04/02 02:29:43 hobbs Exp $ #------------------------------------------------------------------------------ # if {[cequal [info procs Test] {}]} { source [file join [file dirname [info script]] testlib.tcl] } TestRemove GLOBTESTDIR TestTouch GLOBTESTDIR/file1 TestTouch GLOBTESTDIR/dir1/file1 TestTouch GLOBTESTDIR/dir1/file2 TestTouch GLOBTESTDIR/dir1/file3.c TestTouch GLOBTESTDIR/dir2/file1 TestTouch GLOBTESTDIR/dir2/file2.c TestTouch GLOBTESTDIR/dir2/file3 TestTouch GLOBTESTDIR/file2 TestTouch GLOBTESTDIR/dir2/dir3/file1.c TestTouch GLOBTESTDIR/dir2/dir3/file2.c TestTouch GLOBTESTDIR/dir2/dir3/file3 set expectedResult1 [list GLOBTESTDIR/dir1 \ GLOBTESTDIR/dir1/file1 \ GLOBTESTDIR/dir1/file2 \ GLOBTESTDIR/dir1/file3.c \ GLOBTESTDIR/dir2 \ GLOBTESTDIR/dir2/dir3 \ GLOBTESTDIR/dir2/dir3/file1.c\ GLOBTESTDIR/dir2/dir3/file2.c \ GLOBTESTDIR/dir2/dir3/file3 \ GLOBTESTDIR/dir2/file1 \ GLOBTESTDIR/dir2/file2.c \ GLOBTESTDIR/dir2/file3 \ GLOBTESTDIR/file1 \ GLOBTESTDIR/file2] set expectedResult2 [list GLOBTESTDIR/dir1/file3.c \ GLOBTESTDIR/dir2/dir3/file1.c \ GLOBTESTDIR/dir2/dir3/file2.c \ GLOBTESTDIR/dir2/file2.c] set expectedResult3 [list GLOBTESTDIR/dir1/file3.c \ GLOBTESTDIR/dir2/dir3 \ GLOBTESTDIR/dir2/dir3/file1.c \ GLOBTESTDIR/dir2/dir3/file2.c \ GLOBTESTDIR/dir2/dir3/file3 \ GLOBTESTDIR/dir2/file2.c \ GLOBTESTDIR/dir2/file3] Test recursive_glob-1.1 {recursive_glob command} { lsort [recursive_glob GLOBTESTDIR *] } 0 $expectedResult1 Test recursive_glob-1.2 {recursive_glob command} { lsort [recursive_glob GLOBTESTDIR {*.c}] } 0 $expectedResult2 Test recursive_glob-1.3 {recursive_glob command} { lsort [recursive_glob GLOBTESTDIR {*.c *3}] } 0 $expectedResult3 Test recursive_glob-1.4 {for_recursive_glob command} { recursive_glob GLOBTESTDIR/file1 {*.c *3} } 1 {"GLOBTESTDIR/file1" is not a directory} Test recursive_glob-2.1 {for_recursive_glob command} { set result {} for_recursive_glob file GLOBTESTDIR * { lappend result $file } lsort $result } 0 $expectedResult1 Test recursive_glob-2.2 {for_recursive_glob command} { set result {} for_recursive_glob file GLOBTESTDIR {*.c} { lappend result $file } lsort $result } 0 $expectedResult2 Test recursive_glob-2.3 {for_recursive_glob command} { set result {} for_recursive_glob file GLOBTESTDIR {*.c *3} { lappend result $file } lsort $result } 0 $expectedResult3 Test recursive_glob-2.4 {errors in for_recursive_glob command} { for_recursive_glob file GLOBTESTDIR/file1 {*.c *3} { error "should not execute" } } 1 {"GLOBTESTDIR/file1" is not a directory} Test recursive_glob-2.5 {errors in for_recursive_glob command} { list [catch { for_recursive_glob file GLOBTESTDIR {*.c *3} { error "should not execute" FAKE-INFO FAKE-CODE } } msg] $msg [crange $errorInfo 0 8] $errorCode } 0 {1 {should not execute} FAKE-INFO FAKE-CODE} Test recursive_glob-2.6 {break in for_recursive_glob command} { set cnt 0 list [catch { for_recursive_glob file GLOBTESTDIR {*.c *3} { incr cnt break } } msg] $msg $cnt } 0 {0 {} 1} Test recursive_glob-2.7 {break in for_recursive_glob command} { set cnt 0 list [catch { for_recursive_glob file GLOBTESTDIR {*.c *1} { incr cnt if [string match GLOBTESTDIR/dir2/* $file] { break } } } msg] $msg $cnt } 0 {0 {} 5} Test recursive_glob-2.8 {continue in for_recursive_glob command} { set cnt 0 list [catch { for_recursive_glob file GLOBTESTDIR {*.c *3} { incr cnt continue incr cnt } } msg] $msg $cnt } 0 {0 {} 7} Test recursive_glob-2.9 {return in for_recursive_glob command} { proc for_recursive_glob_test cntVar { upvar $cntVar cnt for_recursive_glob file GLOBTESTDIR {*.c *3} { incr cnt return ABCDE } } set cnt 0 list [catch {for_recursive_glob_test cnt} msg] $msg $cnt } 0 {0 ABCDE 1} rename for_recursive_glob_test {} Test recursive_glob-2.10 {return in for_recursive_glob command} { proc for_recursive_glob_test cntVar { upvar $cntVar cnt for_recursive_glob file GLOBTESTDIR {*.c *1} { incr cnt if [string match GLOBTESTDIR/dir2/* $file] { return ABCDE } } } set cnt 0 list [catch {for_recursive_glob_test cnt} msg] $msg $cnt } 0 {0 ABCDE 5} rename for_recursive_glob_test {} TestRemove GLOBTESTDIR unset expectedResult1 expectedResult2 expectedResult3 # cleanup ::tcltest::cleanupTests return tclx8.4-8.4.1.orig/tests/ftrunc.test0000644000000000000000000000736412046313167014136 0ustar # # ftrunc.test # # Tests for the ftruncate command. #--------------------------------------------------------------------------- # Copyright 1992-1999 Karl Lehenbauer and Mark Diekhans. # # Permission to use, copy, modify, and distribute this software and its # documentation for any purpose and without fee is hereby granted, provided # that the above copyright notice appear in all copies. Karl Lehenbauer and # Mark Diekhans make no representations about the suitability of this # software for any purpose. It is provided "as is" without express or # implied warranty. #------------------------------------------------------------------------------ # $Id: ftrunc.test,v 1.3 2002/04/04 06:10:30 hobbs Exp $ #------------------------------------------------------------------------------ # if {[cequal [info procs Test] {}]} { source [file join [file dirname [info script]] testlib.tcl] } TestRemove TRUNCATE.TMP proc CreateTmpFile {name size} { set fh [open $name w] puts -nonewline $fh [replicate X $size] close $fh if {[file size $name] != $size} { error "CreateTmpFile: [file size $name] != $size" } } test filecmds-7.1 {ftruncate tests} { list [catch {ftruncate} msg] $msg } {1 {wrong # args: ftruncate [-fileid] file newsize}} test filecmds-7.2 {ftruncate tests} { list [catch {ftruncate TRUNCATE.TMP 10 1000 200} msg] $msg } {1 {wrong # args: ftruncate [-fileid] file newsize}} test filecmds-7.3 {ftruncate tests} { list [catch {ftruncate -fileid 10} msg] $msg } {1 {wrong # args: ftruncate [-fileid] file newsize}} test filecmds-7.4 {ftruncate tests} { list [catch {ftruncate -fileid TRUNCATE.TMP 10 1000 200} msg] $msg } {1 {wrong # args: ftruncate [-fileid] file newsize}} test filecmds-7.5 {ftruncate tests} {need_truncate} { list [catch {ftruncate NOTHERE.TMP 10} msg] [string tolower $msg] } {1 {nothere.tmp: no such file or directory}} test filecmds-7.6 {ftruncate tests} {need_truncate} { CreateTmpFile TRUNCATE.TMP 1000 set sizes {} ftruncate TRUNCATE.TMP 500 lappend sizes [file size TRUNCATE.TMP] ftruncate TRUNCATE.TMP 50 lappend sizes [file size TRUNCATE.TMP] set sizes } {500 50} test filecmds-7.7 {ftruncate tests} {need_truncate} { CreateTmpFile TRUNCATE.TMP 1000 set sizes {} ftruncate TRUNCATE.TMP 1000 lappend sizes [file size TRUNCATE.TMP] ftruncate TRUNCATE.TMP 0 lappend sizes [file size TRUNCATE.TMP] set sizes } {1000 0} test filecmds-7.7.1 {ftruncate tests} {pcOnly} { list [catch {ftruncate NOTHERE.TMP 10} msg] $msg } {1 {truncating files by path is not available on this system}} test filecmds-7.8 {ftruncate tests} {need_ftruncate} { list [catch {ftruncate -fileid TRUNCATE.TMP 1000} msg] $msg } {1 {can not find channel named "TRUNCATE.TMP"}} test filecmds-7.9 {ftruncate tests} {need_ftruncate} { CreateTmpFile TRUNCATE.TMP 1000 set sizes {} set fh [open TRUNCATE.TMP r+] ftruncate -fileid $fh 500 lappend sizes [file size TRUNCATE.TMP] [fstat $fh size] ftruncate -fileid $fh 50 lappend sizes [file size TRUNCATE.TMP] [fstat $fh size] close $fh set sizes } {500 500 50 50} test filecmds-7.10 {ftruncate tests} {need_ftruncate} { CreateTmpFile TRUNCATE.TMP 1000 set sizes {} set fh [open TRUNCATE.TMP r+] ftruncate -fileid $fh 1000 lappend sizes [file size TRUNCATE.TMP] [fstat $fh size] ftruncate -fileid $fh 0 lappend sizes [file size TRUNCATE.TMP] [fstat $fh size] close $fh set sizes } {1000 1000 0 0} test filecmds-7.10.1 {ftruncate tests} {pcOnly} { set fh [open TRUNCATE.TMP w] set result [list [catch {ftruncate -fileid $fh 0} msg] $msg] close $fh set result } {0 {}} rename CreateTmpFile {} TestRemove TRUNCATE.TMP # cleanup ::tcltest::cleanupTests return tclx8.4-8.4.1.orig/tests/testlib.tcl0000644000000000000000000000733012046313167014077 0ustar # # testlib.tcl -- # # Test support routines. Some of these are based on routines provided with # standard Tcl. #------------------------------------------------------------------------------ # Copyright 1992-1999 Karl Lehenbauer and Mark Diekhans. # Copyright 2002 ActiveState Corporation. # # Permission to use, copy, modify, and distribute this software and its # documentation for any purpose and without fee is hereby granted, provided # that the above copyright notice appear in all copies. Karl Lehenbauer and # Mark Diekhans make no representations about the suitability of this # software for any purpose. It is provided "as is" without express or # implied warranty. #------------------------------------------------------------------------------ # $Id: testlib.tcl,v 1.4 2002/04/04 06:10:30 hobbs Exp $ #------------------------------------------------------------------------------ # # Save the unknown command in a variable SAVED_UNKNOWN. To get it back, eval # that variable. if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import ::tcltest::* } package require Tclx 8.4 foreach need { fchown fchmod flock fsync ftruncate msgcats posix_signals symlink signal_restart truncate waitpid } { set ::tcltest::testConstraints(need_$need) [infox have_$need] } set ::tcltest::testConstraints(need_chmod) [llength [info commands chmod]] if {[cequal $::tcl_platform(platform) "unix"]} { set ::tcltest::testConstraints(isRoot) [cequal [id user] "root"] set ::tcltest::testConstraints(isNotRoot) \ [expr {![cequal [id user] "root"]}] } # Genenerate a unique file record that can be verified. The record # grows quite large to test the dynamic buffering in the file I/O. proc GenRec {id} { return [format "Key:%04d {This is a test of file I/O (%d)} KeyX:%04d %s" \ $id $id $id [replicate :@@@@@@@@: $id]] } # # Routine to execute tests and compare to expected results. # proc Test {name description body int_result result} { if {$int_result == 0} { uplevel 1 [list test $name $description $body $result] } elseif {$int_result == 1} { uplevel 1 [list test $name $description \ "list \[catch {$body} msg\] \$msg" [list 1 $result]] } else { puts stderr "FIX OUTDATED TEST: $test_name $test_description" } } # Proc to fork and exec child that loops until it gets a signal. # Can optionally set its pgroup. Wait till child has actually execed or # kill breaks on some systems (i.e. AIX). Windows is a drag, since the # command line parsing is really dumb. Pass it in a file instead. proc ForkLoopingChild {{setPGroup 0}} { global tcl_platform set childProg { file delete CHILD.RUN catch {while {1} {after 1000;update}} exit 10 } # Create semaphore (it also contains the program to run for windows). set fh [open CHILD.RUN w] puts $fh $childProg close $fh flush stdout flush stderr if {[cequal $tcl_platform(platform) unix]} { set newPid [fork] if {$newPid == 0} { if $setPGroup { id process group set } catch {execl $::tcltest::tcltest CHILD.RUN} msg puts stderr "execl failed (ForkLoopingChild): $msg" exit 1 } } if {[cequal $tcl_platform(platform) windows]} { if $setPGroup { error "setpgroup not supported on windows" } set newPid [execl $::tcltest::tcltest CHILD.RUN] } # Wait till the child is actually running. while {[file exists CHILD.RUN]} { sleep 1 } return $newPid } # # Create a file. If the directory doesn't exist, create it. # proc TestTouch file { file mkdir [file dirname $file] close [open $file w] } # # Remove files and directories with out errors. # proc TestRemove args { foreach f $args { catch {file delete -force $f} } } tclx8.4-8.4.1.orig/tests/id.test0000644000000000000000000000362512046313166013224 0ustar # # id.test # # Tests for the id command. #--------------------------------------------------------------------------- # Copyright 1992-1999 Karl Lehenbauer and Mark Diekhans. # # Permission to use, copy, modify, and distribute this software and its # documentation for any purpose and without fee is hereby granted, provided # that the above copyright notice appear in all copies. Karl Lehenbauer and # Mark Diekhans make no representations about the suitability of this # software for any purpose. It is provided "as is" without express or # implied warranty. #------------------------------------------------------------------------------ # $Id: id.test,v 1.2 2002/04/02 02:29:43 hobbs Exp $ #------------------------------------------------------------------------------ # # FIX: These are very basic tests. Better are needed. if {[cequal [info procs Test] {}]} { source [file join [file dirname [info script]] testlib.tcl] } if [cequal $tcl_platform(platform) windows] { echo " * The id command tests have not been ported to Win32" return } Test id-1.1 {id arg checking} { id } 1 {wrong # args: id arg ?arg...?} Test id-1.2 {id arg checking} { id x } 1 {second arg must be one of "convert", "effective", "process", "user", "userid", "group", "groupid", "groups", "groupids", or "host"} Test id-2.1 {id convert arg checking} { id convert x } 1 {wrong # args: id convert type value} Test id-2.2 {id convert arg checking} { id convert x y } 1 {third arg must be "user", "userid", "group" or "groupid", got "x"} Test id-3.1 {id convert} { id convert user root } 0 {0} Test id-4.2 {id convert} { id convert userid 0 } 0 {root} # FIX: Add "group" or "groupid" # FIX: ADD: # effective # process # user # userid # group # groupid # groups # groupids # host # FIX: Make sure this doesn't core dump./ id groups # cleanup ::tcltest::cleanupTests return tclx8.4-8.4.1.orig/tests/convlib.test0000644000000000000000000000475712046313167014274 0ustar # # convlib.test # # Tests for tcl.tlib convert_lib routine. #--------------------------------------------------------------------------- # Copyright 1992-1999 Karl Lehenbauer and Mark Diekhans. # # Permission to use, copy, modify, and distribute this software and its # documentation for any purpose and without fee is hereby granted, provided # that the above copyright notice appear in all copies. Karl Lehenbauer and # Mark Diekhans make no representations about the suitability of this # software for any purpose. It is provided "as is" without express or # implied warranty. #------------------------------------------------------------------------------ # $Id: convlib.test,v 1.2 2002/04/02 02:29:43 hobbs Exp $ #------------------------------------------------------------------------------ # if {[cequal [info procs Test] {}]} { source [file join [file dirname [info script]] testlib.tcl] } catch {file delete -force convlib.tmp} file mkdir convlib.tmp # Create a temporary source files and generate an index. loop num 0 5 { set fh [open convlib.tmp/tmp${num}.tcl w] puts $fh "proc LoadProc${num}A {} {return @LoadProc${num}A@}" puts $fh "proc LoadProc${num}B {} {return @LoadProc${num}B@}" close $fh } set fh [open convlib.tmp/init.tcl w] puts $fh "proc InitTcl {} {return @InitTcl@}" close $fh auto_mkindex convlib.tmp *.tcl # Proc that validates the library by executing procs out of it. proc LibValidate {testid testname} { loop num 0 5 { Test $testid.1 $testname { LoadProc${num}A } 0 "@LoadProc${num}A@" Test $testid.2 $testname { LoadProc${num}B } 0 "@LoadProc${num}B@" Test $testid.3 $testname { InitTcl } 1 {invalid command name "InitTcl"} } } # # Now convert and load the library, see if we can actually use it. # Test convlib-1.1 {Convert library tests} { TestRemove convlib.tmp/tmp.tlib file delete convlib.tmp/tmp.tndx convert_lib convlib.tmp/tclIndex convlib.tmp/tmp "init.tcl" list [file exists convlib.tmp/tmp.tlib] [file exists convlib.tmp/tmp.tndx] } 0 {1 1} Test convlib-1.2 {Convert library tests} { TestRemove convlib.tmp/tmp.tlib file delete convlib.tmp/tmp.tndx convert_lib convlib.tmp/tclIndex convlib.tmp/tmp.tlib "init.tcl" list [file exists convlib.tmp/tmp.tlib] [file exists convlib.tmp/tmp.tndx] } 0 {1 1} loadlibindex convlib.tmp/tmp.tlib LibValidate convlib-1.3 {Convert library tests} TestRemove convlib.tmp # cleanup ::tcltest::cleanupTests return tclx8.4-8.4.1.orig/tests/fmath.test0000644000000000000000000000642212046313166013725 0ustar # # fmath.test # # Tests for the following floating point math compatibility procs: # acos, asin, atan, cos, sin, tan, cosh, sinh, tanh, # exp, log, log10, sqrt, fabs, floor, ceil, fmod, pow. #--------------------------------------------------------------------------- # Copyright 1992-1999 Karl Lehenbauer and Mark Diekhans. # # Permission to use, copy, modify, and distribute this software and its # documentation for any purpose and without fee is hereby granted, provided # that the above copyright notice appear in all copies. Karl Lehenbauer and # Mark Diekhans make no representations about the suitability of this # software for any purpose. It is provided "as is" without express or # implied warranty. #------------------------------------------------------------------------------ # $Id: fmath.test,v 1.3 2005/11/17 23:55:21 hobbs Exp $ #------------------------------------------------------------------------------ # if {[cequal [info procs Test] {}]} { source [file join [file dirname [info script]] testlib.tcl] } set F_E 2.71828 set F_LN10 2.30258 set F_PI 3.14159265358979 set F_PI_180 0.0174533 set F_PI_4 0.785398 set F_PI_2 1.5708 set F_SQRT2 1.41421 # Check that a floating point value is reasonably within range. If so, return # 1, if not, return a message. proc fchecknum {got expect} { global ModuleName set lowExpect [expr {$expect * 0.9999}] set hiExpect [expr {$expect * 1.0001}] if {($got < $lowExpect) || ($got > $hiExpect)} { return [format {wanted something close to %s, got %s} $expect $got] } return 1 } Test fmath-1.1 {acos tests} { fchecknum [acos 0] 1.5708 } 0 1 Test fmath-1.2 {acos tests} { fchecknum [acos $F_PI_180-.5] 2.07436 } 0 1 Test fmath-1.3 {acos tests} { fchecknum [acos $F_PI_4] 0.667457 } 0 1 Test fmath-1.4 {acos tests} { fchecknum [acos .25*.25] 1.50826 } 0 1 Test fmath-1.5 {asin tests} { fchecknum [asin 1.3-.4] 1.11977 } 0 1 Test fmath-1.6 {atan tests} { fchecknum [atan 1.0-.25] 0.643501 } 0 1 Test fmath-1.7 {sin tests} { fchecknum [sin 1.0-.1] 0.783327 } 0 1 Test fmath-1.8 {tan tests} { fchecknum [tan .01*10] 0.100335 } 0 1 Test fmath-1.9 {cosh tests} { fchecknum [cosh 1.2] 1.81066 } 0 1 Test fmath-1.10 {sinh tests} { fchecknum [sinh .25+10] 14141.3 } 0 1 Test fmath-1.11 {tanh tests} { fchecknum [tanh 1.5/2] 0.635149 } 0 1 Test fmath-1.12 {exp tests} { fchecknum [exp 1.4] 4.0552 } 0 1 Test fmath-1.13 {log tests} { fchecknum [log (110%3)*8] 2.77259 } 0 1 Test fmath-1.14 {log10 tests} { fchecknum [log10 0.5*10] 0.69897 } 0 1 Test fmath-1.15 {sqrt tests} { fchecknum [sqrt 1.2*2] 1.54919 } 0 1 Test fmath-1.16 {fabs tests} { fchecknum [fabs 1.2-10.5] 9.3 } 0 1 Test fmath-1.17 {floor tests} { fchecknum [floor 1.2*10.3] 12 } 0 1 Test fmath-1.18 {ceil tests} { fchecknum [ceil 1.5*2.6] 4 } 0 1 Test fmath-1.19 {fmod tests} { fchecknum [fmod 1.2*3 1.0/.25] 3.6 } 0 1 Test fmath-1.20 {pow tests} { fchecknum [pow 13.6*.78 1.2] 17.0122 } 0 1 if {$tcl_version > 8.4} { Test fmath-1.21-8.5 {math error tests} { pow 10000 100000 } 0 Inf } else { Test fmath-1.21 {math error tests} { pow 10000 100000 } 1 {floating-point value too large to represent} } # cleanup ::tcltest::cleanupTests return tclx8.4-8.4.1.orig/tests/process.test0000644000000000000000000001367412046313167014314 0ustar # # process.test # # Tests for the fork, execl and wait commands. #--------------------------------------------------------------------------- # Copyright 1992-1999 Karl Lehenbauer and Mark Diekhans. # # Permission to use, copy, modify, and distribute this software and its # documentation for any purpose and without fee is hereby granted, provided # that the above copyright notice appear in all copies. Karl Lehenbauer and # Mark Diekhans make no representations about the suitability of this # software for any purpose. It is provided "as is" without express or # implied warranty. #------------------------------------------------------------------------------ # $Id: process.test,v 1.4 2002/04/04 06:10:30 hobbs Exp $ #------------------------------------------------------------------------------ # if {[cequal [info procs Test] {}]} { source [file join [file dirname [info script]] testlib.tcl] } test process-1.1.pc {fork, execl, wait tests} {pcOnly} { removeFile script makeFile {after 1000;update;exit 12} script set newPid [execl $::tcltest::tcltest script] lrange [wait $newPid] 1 end } {EXIT 12} if {[cequal $tcl_platform(platform) windows]} { ;# WIN32??? echo process win32 work not completed, tests skipped. return } # # Fork without exec will not work under Tk, skip this test # if {[info exists tk_version]} { puts "*************************************************************" puts "Process tests are constructed in a way that does not work" puts "under Tk. Test skipped." puts "*************************************************************" return } # Test fork, execl, and wait commands. test process-1.1.unix {fork, execl, wait tests} {unixOnly} { set newPid [fork] if {$newPid == 0} { removeFile script makeFile {after 1000;update;exit 12} script catch {execl $::tcltest::tcltest script} msg puts stderr "execl failed 1.1: $msg" exit 1 } lrange [wait $newPid] 1 end } {EXIT 12} test process-1.2 {fork, execl, wait tests} { set newPid [ForkLoopingChild] sleep 1 kill $newPid lrange [wait $newPid] 1 end } {SIG SIGTERM} set newPid1 [ForkLoopingChild] set newPid2 [ForkLoopingChild] test process-1.3 {fork, execl, wait tests} { sleep 3 ;# Give em a chance to get going. kill [list $newPid1 $newPid2] list [wait $newPid1] [wait $newPid2] } [list "$newPid1 SIG SIGTERM" "$newPid2 SIG SIGTERM"] test process-1.4 {fork, execl, wait tests} { list [catch {fork foo} msg] $msg } {1 {wrong # args: fork}} test process-1.5 {fork, execl, wait tests} { list [catch {wait baz} msg] $msg } {1 {invalid pid or process group id "baz"}} test process-1.6 {fork, execl, wait tests} { set testPid [ForkLoopingChild] kill $testPid set result [wait $testPid] lrange $result 1 end } {SIG SIGTERM} test process-1.7 {fork, execl, wait tests} {unixOnly} { set newPid [fork] if {$newPid == 0} { set script "sleep 1; if test \"\$0\" = \"FOOPROC\"; then\n\ exit 10;\nfi\nexit 18;" catch [list execl -argv0 FOOPROC /bin/sh [list -c $script]] msg puts stderr "execl failed 1.7: $msg" exit 1 } lrange [wait $newPid] 1 end } {EXIT 10} # Try execl in various wrong ways. We try it in a separate process, first, # in case by error we exec something. Test process-1.8 {fork, execl, wait tests} { set newPid [fork] if {$newPid == 0} { catch {execl -argv0 FOOPROC} exit 24 } if {[lrange [wait $newPid] 1 end] == {EXIT 24}} { execl -argv0 FOOPROC } else { concat "appears to have exec-ed something" } } 1 {wrong # args: execl ?-argv0 argv0? prog ?argList?} Test process-1.9 {fork, execl, wait tests} { removeFile script makeFile {exit 0} {script} set newPid [fork] if {$newPid == 0} { catch {execl -argv0 FOOPROC $::tcltest::tcltest script badarg} exit 23 } if {[lrange [wait $newPid] 1 end] == {EXIT 23}} { execl -argv0 FOOPROC $::tcltest::tcltest script badarg } else { concat "appears to have exec-ed something" } } 1 {wrong # args: execl ?-argv0 argv0? prog ?argList?} Test process-1.10 {fork, execl, wait tests} { removeFile script makeFile {exit 0} {script} set newPid [fork] if {$newPid == 0} { catch {execl $::tcltest::tcltest script badarg} exit 24 } sleep 1 if {[lrange [wait $newPid] 1 end] == {EXIT 24}} { execl $::tcltest::tcltest script badarg } } 1 {wrong # args: execl ?-argv0 argv0? prog ?argList?} Test process-1.11 {fork, execl, wait tests} { set newPid [fork] if {$newPid == 0} { catch {execl} exit 24 } sleep 1 if {[lrange [wait $newPid] 1 end] == {EXIT 24}} { execl } else { concat "appears to have exec-ed something" } } 1 {wrong # args: execl ?-argv0 argv0? prog ?argList?} Test process-1.12 {fork, execl, wait tests} { set newPid [fork] if {$newPid == 0} { catch {execl -argv0} exit 24 } sleep 1 if {[lrange [wait $newPid] 1 end] == {EXIT 24}} { execl -argv0 } else { concat "appears to have exec-ed something" } } 1 {wrong # args: execl ?-argv0 argv0? prog ?argList?} # Test extended wait functionality, if available. test process-2.1 {fork, execl, wait tests} {need_waitpid} { set testPid [ForkLoopingChild] set result1 [wait -nohang $testPid] kill $testPid set result2 [wait $testPid] list $result1 [lrange $result2 1 end] } {{} {SIG SIGTERM}} test process-2.2 {fork, execl, wait tests} {need_waitpid} { set testPid [ForkLoopingChild 1] set result1 [wait -nohang -pgroup $testPid] kill $testPid set result2 [wait -pgroup $testPid] list $result1 [lrange $result2 1 end] } {{} {SIG SIGTERM}} test process-2.3 {fork, execl, wait tests} {need_waitpid} { set testPid [ForkLoopingChild 1] set result1 [wait -nohang -pgroup -untraced $testPid] kill $testPid set result2 [wait -pgroup -untraced $testPid] list $result1 [lrange $result2 1 end] } {{} {SIG SIGTERM}} # cleanup ::tcltest::cleanupTests return tclx8.4-8.4.1.orig/tests/pipe.test0000644000000000000000000000454612046313166013570 0ustar # # pipe.test # # Tests for the pipe command. #--------------------------------------------------------------------------- # Copyright 1992-1999 Karl Lehenbauer and Mark Diekhans. # # Permission to use, copy, modify, and distribute this software and its # documentation for any purpose and without fee is hereby granted, provided # that the above copyright notice appear in all copies. Karl Lehenbauer and # Mark Diekhans make no representations about the suitability of this # software for any purpose. It is provided "as is" without express or # implied warranty. #------------------------------------------------------------------------------ # $Id: pipe.test,v 1.3 2002/04/04 06:10:30 hobbs Exp $ #------------------------------------------------------------------------------ # if {[cequal [info procs Test] {}]} { source [file join [file dirname [info script]] testlib.tcl] } # # Fork without exec will not work under Tk, skip this test # if {[info exists tk_version]} { puts "******************************************************************" puts "The pipe commands test require fork, which does not work under Tk." puts "Test skipped." puts "******************************************************************" return } # FIX: Need win95 tests for pipe. # # Create child process to read from the pipe and write a message # back. # proc PipeChild {id numRecs readChan} { flush stdout ;# Not going to exec, must clean up the buffers. flush stderr set pid [fork] if {$pid != 0} { return $pid } for {set cnt 0} {$cnt < $numRecs} {incr cnt} { Test filecmds-4.1 {pipe tests} { if {![gets $readChan msgBuf]} { set msgBuf "Premature eof on pipe" set cnt $numRecs } set msgBuf } 0 [GenRec $cnt] } close $readChan exit 0 } test pipe-1.1 {pipe tests} { list [catch {pipe x y z} msg] $msg } {1 {wrong # args: pipe ?fileId_var_r fileId_var_w?}} test pipe-1.2 {pipe tests} {unixOnly} { pipe readChan writeChan set pid [PipeChild pipe-1.3 50 $readChan] for {set cnt 0} {$cnt < 50} {incr cnt} { puts $writeChan [GenRec $cnt] } flush $writeChan Test pipe-1.32 {pipe tests} { wait $pid } 0 [list $pid EXIT 0] close $readChan close $writeChan } {} # cleanup ::tcltest::cleanupTests return tclx8.4-8.4.1.orig/tests/forfile.test0000644000000000000000000000504512046313167014255 0ustar # # forfile.test # # Tests for tcl.tlib for_file routine. #--------------------------------------------------------------------------- # Copyright 1992-1999 Karl Lehenbauer and Mark Diekhans. # # Permission to use, copy, modify, and distribute this software and its # documentation for any purpose and without fee is hereby granted, provided # that the above copyright notice appear in all copies. Karl Lehenbauer and # Mark Diekhans make no representations about the suitability of this # software for any purpose. It is provided "as is" without express or # implied warranty. #------------------------------------------------------------------------------ # $Id: forfile.test,v 1.2 2002/04/02 02:29:43 hobbs Exp $ #------------------------------------------------------------------------------ # if {[cequal [info procs Test] {}]} { source [file join [file dirname [info script]] testlib.tcl] } set outfp [open FORFILE.TMP w] puts $outfp line1 puts $outfp line2 puts $outfp line3 close $outfp unset outfp catch {unset result} Test for_file-1.1 {for_file command} { set ret [for_file line FORFILE.TMP {lappend result $line}] list $result $ret } 0 {{line1 line2 line3} {line1 line2 line3}} Test for_file-1.2 {errors in for_file command} { string tolower [list [catch { for_file line _non_existent_ { echo $line } } msg] $msg $errorCode] } 0 [list 1 {couldn't open "_non_existent_": no such file or directory} \ {posix enoent {no such file or directory}}] Test for_file-1.3 {errors in for_file command} { list [catch { for_file line FORFILE.TMP { error fakeResult fakeInfo fakeCode } } msg] $msg [crange $errorInfo 0 7] $errorCode } 0 [list 1 fakeResult fakeInfo fakeCode] Test for_file-1.4 {break in for_file command} { set cnt 0 list [catch { for_file line FORFILE.TMP { incr cnt break } } msg] $msg $cnt } 0 {0 {} 1} Test for_file-1.5 {continue in for_file command} { set cnt 0 list [catch { for_file line FORFILE.TMP { incr cnt continue incr cnt 20 } } msg] $msg $cnt } 0 {0 {} 3} Test for_file-1.6 {return in for_file command} { proc for_file_test {cntVar} { upvar $cntVar cnt for_file line FORFILE.TMP { incr cnt return abcd } } set cnt 0 list [catch {for_file_test cnt} msg] $msg $cnt } 0 {0 abcd 1} rename for_file_test {} TestRemove FORFILE.TMP unset result # cleanup ::tcltest::cleanupTests return tclx8.4-8.4.1.orig/tests/lassign.test0000644000000000000000000000321312046313167014262 0ustar # # lassign.test # # Tests for lassign command. #--------------------------------------------------------------------------- # Copyright 1992-1999 Karl Lehenbauer and Mark Diekhans. # # Permission to use, copy, modify, and distribute this software and its # documentation for any purpose and without fee is hereby granted, provided # that the above copyright notice appear in all copies. Karl Lehenbauer and # Mark Diekhans make no representations about the suitability of this # software for any purpose. It is provided "as is" without express or # implied warranty. #------------------------------------------------------------------------------ # $Id: lassign.test,v 1.2 2002/04/02 02:29:43 hobbs Exp $ #------------------------------------------------------------------------------ # if {[cequal [info procs Test] {}]} { source [file join [file dirname [info script]] testlib.tcl] } Test lassign-1.1 {lassign command} { lassign "a b {c d} e" alpha beta gamma delta epsilon list $alpha $beta $gamma $delta $epsilon } 0 "a b {c d} e {}" Test lassign-1.2 {lassign command} { set remain [lassign "a b {c d} e gg hhh ii" alpha beta gamma delta] list $alpha $beta $gamma $delta $remain } 0 "a b {c d} e {gg hhh ii}" Test lassign-1.3 {lassign command} { lassign "a b {c d} e" } 1 {wrong # args: lassign list varname ?varname..?} Test lassign-1.4 {lassign command} { lassign "a b {c d} e" array(alpha) array(beta) array(gamma) array(delta) array(epsilon) list $array(alpha) $array(beta) $array(gamma) $array(delta) $array(epsilon) } 0 "a b {c d} e {}" catch {unset alpha beta gamma delta epsilon} # cleanup ::tcltest::cleanupTests return tclx8.4-8.4.1.orig/tests/dup.test0000644000000000000000000001626212046313167013422 0ustar # # dup.test # # Tests for the dup command. #--------------------------------------------------------------------------- # Copyright 1992-1999 Karl Lehenbauer and Mark Diekhans. # # Permission to use, copy, modify, and distribute this software and its # documentation for any purpose and without fee is hereby granted, provided # that the above copyright notice appear in all copies. Karl Lehenbauer and # Mark Diekhans make no representations about the suitability of this # software for any purpose. It is provided "as is" without express or # implied warranty. #------------------------------------------------------------------------------ # $Id: dup.test,v 1.3 2002/04/03 02:44:21 hobbs Exp $ #------------------------------------------------------------------------------ # if {[cequal [info procs Test] {}]} { source [file join [file dirname [info script]] testlib.tcl] } # FIX: Need tests on sockets. # Create a test file TestRemove DUP.TMP DUP2.TMP set testFH [open DUP.TMP w] for {set cnt 0} {$cnt < 100} {incr cnt} { puts $testFH [GenRec $cnt] } close $testFH test dup-1.1 {dup argument checking} { list [catch {dup} msg] $msg } {1 {wrong # args: dup channelId ?targetChannelId?}} test dup-1.2 {dup argument checking} { list [catch {dup a b c} msg] $msg } {1 {wrong # args: dup channelId ?targetChannelId?}} test dup-1.3 {dup argument checking} { list [catch {dup a} msg] $msg } {1 {can not find channel named "a"}} test dup-1.4 {dup argument checking} { list [catch {dup stdin a} msg] $msg } {1 {invalid channel id: a}} test dup-2.1 {dup tests} { set testFH [open DUP.TMP] set testFH2 [dup $testFH] gets $testFH2 testRec close $testFH close $testFH2 set testRec } [GenRec 0] test dup-2.2 {dup tests} {unixOnly} { set testFH [open DUP.TMP] set testFH2 [open DUP2.TMP w] set testFH2 [dup $testFH $testFH2] gets $testFH2 testRec close $testFH close $testFH2 set testRec } [GenRec 0] test dup-2.3 {dup tests} {pcOnly} { set testFH [open DUP.TMP] set testFH2 [open DUP2.TMP w] set result [list [catch {dup $testFH $testFH2} msg] $msg] close $testFH close $testFH2 set result } {1 {on MS Windows, only stdin, stdout or stderr maybe the dup target}} # # Test to channels to the same file, including duping of some channel options. # test dup-3.0 {dup tests} { set testFH1 [open DUP2.TMP w] fconfigure $testFH1 -buffering line set testFH2 [dup $testFH1] set result [fconfigure $testFH2 -buffering] puts $testFH1 "line 1" puts $testFH2 "line 2" puts $testFH1 "line 3" puts $testFH2 "line 4" puts $testFH1 "line 5" puts $testFH2 "line 6" close $testFH1 close $testFH2 set testFH1 [open DUP2.TMP] while {[gets $testFH1 line] >= 0} { lappend result $line } close $testFH1 set result } {line {line 1} {line 2} {line 3} {line 4} {line 5} {line 6}} # # Test passing a file via dup to a child process. # FIX: Should really have a way of doing this on windows. # if [cequal $tcl_platform(platform) unix] { set data {{now is the time} {for all good programmers} {to come to the aid} {of their software}} set inFH [open INCMDS.TMP w] catch {file delete OUTPUT.TMP} foreach line $data { puts $inFH "puts stdout \"$line\"" } puts $inFH {flush stdout} puts $inFH {exit 0} close $inFH flush stdout flush stderr if {[set childPid [fork]] == 0} { set inFH [open INCMDS.TMP r] set outFH [open OUTPUT.TMP w] dup $inFH stdin close $inFH dup $outFH stdout close $outFH removeFile script makeFile {package require Tclx; commandloop -prompt1 {} -prompt2 {}} \ script catch {execl $::tcltest::tcltest script} msg puts stderr "execl failed: $msg" exit 1 } test dup-4.1 {dup tests} { wait $childPid } [list $childPid EXIT 0] set outFH [open OUTPUT.TMP r] foreach line $data { test dup-4.2 {dup tests} { gets $outFH } $line } close $outFH } # Test binding of open files to ids on Unix systems. Solaris opens pipes RDWR, # so skip some tests if this is the case. if [cequal $tcl_platform(platform) unix] { pipe fromChild toParent pipe fromParent toChild flush stdout flush stderr if {[set childPid [fork]] == 0} { catch { close $fromChild close $toChild set toParent [crange $toParent 4 end] set fromParent [crange $fromParent 4 end] removeFile script makeFile [subst { package require Tclx set toParent \[dup $toParent\] set fromParent \[dup $fromParent\] if {!\[fcntl \$fromParent RDWR\]} { puts \$toParent "DOING ACCESS CHECK" flush \$toParent catch {puts \$fromParent arf} msg puts \$toParent "msg1: \$msg" flush \$toParent catch {gets \$toParent} msg puts \$toParent "msg2: \$msg" flush \$toParent } else { puts \$toParent "SKIPPING ACCESS CHECK" flush \$toParent } while {\[gets \$fromParent msg\] >= 0} { puts \$toParent "got: \$msg" flush \$toParent } }] {script} execl $::tcltest::tcltest script } msg puts stderr "child failed: $msg" exit 1 } close $toParent close $fromParent test dup-5.1 {dup tests} { set line [gets $fromChild] switch $line { {DOING ACCESS CHECK} { set doingAccess 1 concat OK } {SKIPPING ACCESS CHECK} { set doingAccess 0 concat OK } default { set doingAccess 0 list $line } } } OK if ![fcntl $toChild RDWR] { test dup-5.2 {dup tests} { list [catch {gets $toChild} msg] $msg } [list 1 "channel \"$toChild\" wasn't opened for reading"] test dup-5.3 {dup tests} { list [catch {puts $fromChild arf} msg] $msg } [list 1 "channel \"$fromChild\" wasn't opened for writing"] } if $doingAccess { test dup-5.4 {dup tests} { gets $fromChild line if [string match {msg1: channel "*" wasn't opened for writing} $line] { list OK } else { list $line } } OK test dup-5.5 {dup tests} { gets $fromChild line if [string match {msg2: channel "*" wasn't opened for reading} $line] { list OK } else { list $line } } OK } test dup-5.6 {dup tests} { puts $toChild "test 5.2" flush $toChild gets $fromChild } {got: test 5.2} test dup-5.7 {dup tests} { puts $toChild "test 3.3" flush $toChild gets $fromChild } {got: test 3.3} test dup-5.8 {dup tests} { close $toChild close $fromChild wait $childPid } [list $childPid EXIT 0] test dup-5.9 {dup tests} { set stat [catch {dup 100}] list $stat [lrange $errorCode 0 1] } {1 {POSIX EBADF}} } TestRemove DUP.TMP DUP2.TMP INCMDS.TMP OUTPUT.TMP # cleanup ::tcltest::cleanupTests return tclx8.4-8.4.1.orig/tests/chartype.test0000644000000000000000000001403212046313167014442 0ustar # # chartype.test # # Tests for the ctype command. #--------------------------------------------------------------------------- # Copyright 1992-1999 Karl Lehenbauer and Mark Diekhans. # # Permission to use, copy, modify, and distribute this software and its # documentation for any purpose and without fee is hereby granted, provided # that the above copyright notice appear in all copies. Karl Lehenbauer and # Mark Diekhans make no representations about the suitability of this # software for any purpose. It is provided "as is" without express or # implied warranty. #------------------------------------------------------------------------------ # $Id: chartype.test,v 1.2 2002/04/02 02:29:43 hobbs Exp $ #------------------------------------------------------------------------------ # if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import ::tcltest::* } # Use format to convert number to character. proc numToChar num { return [format %c $num] } # Use scan to convert character to number. proc charToNum str { scan $str %c num return $num } test chartype-1.1 {ctype tests} { ctype digit 01234567 } 1 test chartype-1.2 {ctype tests} { ctype digit abc123cd } 0 test chartype-1.3 {ctype tests} { ctype xdigit 01234567abcdefABCDEF } 1 test chartype-1.4 {ctype tests} { ctype xdigit XMc123cd } 0 test chartype-1.4.1 {ctype tests} { list [ctype -failindex failIdx xdigit XMc123cd] $failIdx } {0 0} test chartype-1.5 {ctype tests} { ctype lower abcdefgh } 1 test chartype-1.6 {ctype tests} { ctype lower abcDeFgh } 0 test chartype-1.6.1 {ctype tests} { list [ctype -failindex failIdx lower abcDeFgh] $failIdx } {0 3} test chartype-1.7 {ctype tests} { ctype upper ABCDEFGH } 1 test chartype-1.8 {ctype tests} { ctype upper abcDeFgh } 0 test chartype-1.8.1 {ctype tests} { list [ctype -failindex failIdx upper DabcDeFgh] $failIdx } {0 1} test chartype-1.9 {ctype tests} { ctype alpha abcdXYZ } 1 test chartype-1.10 {ctype tests} { ctype alpha abc123cd } 0 test chartype-1.10.1 {ctype tests} { list [ctype -failindex failIdx alpha abc123cd] $failIdx } {0 3} test chartype-1.11 {ctype tests} { ctype alnum 0123ABC7 } 1 test chartype-1.12 {ctype tests} { ctype alnum ab.%23cd } 0 test chartype-1.12.1 {ctype tests} { list [ctype -failindex failIdx alnum ab.%23cd] $failIdx } {0 2} test chartype-1.13 {ctype tests} { ctype space " \t\n " } 1 test chartype-1.14 {ctype tests} { ctype space "ab \t z" } 0 test chartype-1.14.1 {ctype tests} { list [ctype -failindex failIdx space "ab \t z"] $failIdx } {0 0} test chartype-1.15 {ctype tests} { ctype cntrl "[ctype char 7][ctype char 15][ctype char 20]" } 1 test chartype-1.16 {ctype tests} { ctype cntrl "[ctype char 7]abcd" } 0 test chartype-1.16,1 {ctype tests} { list [ctype -failindex failIdx cntrl "[ctype char 7]abcd"] $failIdx } {0 1} test chartype-1.17 {ctype tests} { ctype punct ".,:;" } 1 test chartype-1.18 {ctype tests} { ctype punct ".,:;ab" } 0 test chartype-1.18.1 {ctype tests} { list [ctype -failindex failIdx punct ".,:;ab"] $failIdx } {0 4} test chartype-1.19 {ctype tests} { ctype print "01 :;.567" } 1 test chartype-1.20 {ctype tests} { ctype print "[ctype char 7][ctype char 15]abc" } 0 test chartype-1.20.1 {ctype tests} { list [ctype -failindex failIdx print "[ctype char 7][ctype char 15]abc"] $failIdx } {0 0} test chartype-1.21 {ctype tests} { ctype graph "ab.zxy" } 1 test chartype-1.22 {ctype tests} { ctype graph "abc 3cd" } 0 test chartype-1.22.1 {ctype tests} { list [ctype -failindex failIdx graph "abc 3cd"] $failIdx } {0 3} test chartype-1.23 {ctype tests} { ctype ascii 01234567 } 1 test chartype-1.24 {ctype tests} { ctype ascii "[ctype char 220][ctype char 126]123cd" } 0 test chartype-1.24.1 {ctype tests} { list [ctype -failindex failIdx ascii "[ctype char 220][ctype char 126]123cd"] $failIdx } {0 0} test chartype-1.25 {ctype tests} { list [catch {ctype ascii} msg] $msg } {1 {wrong # args: ctype ?-failindex var? class string}} test chartype-1.25.1 {ctype tests} { list [catch {ctype ascii string junk} msg] $msg } {1 {wrong # args: ctype ?-failindex var? class string}} test chartype-1.25.2 {ctype tests} { list [catch {ctype -failindex ascii} msg] $msg } {1 {wrong # args: ctype ?-failindex var? class string}} test chartype-1.25.3 {ctype tests} { list [catch {ctype -failindex failIdx ascii} msg] $msg } {1 {wrong # args: ctype ?-failindex var? class string}} test chartype-1.25.4 {ctype tests} { list [catch {ctype -failindex failIdx ascii string junk} msg] $msg } {1 {wrong # args: ctype ?-failindex var? class string}} test chartype-1.26 {ctype tests} { list [catch {ctype ascbb foo} msg] $msg } {1 {unrecognized class specification: "ascbb", expected one of: alnum, alpha, ascii, char, cntrl, digit, graph, lower, ord, print, punct, space, upper or xdigit}} test chartype-1.27 {ctype char tests} { ctype char 65 } [numToChar 65] test chartype-1.28 {ctype char tests} { ctype char 97 } [numToChar 97] test chartype-1.29 {ctype char tests} { ctype char 57 } [numToChar 57] test chartype-1.30 {ctype char tests} { ctype char 35 } [numToChar 35] test chartype-1.32 {ctype ord tests} { ctype ord A } [charToNum A] test chartype-1.33 {ctype ord tests} { ctype ord a } [charToNum a] test chartype-1.34 {ctype ord tests} { ctype ord 9 } [charToNum 9] test chartype-1.35 {ctype ord tests} { ctype ord "#" } [charToNum \#] test chartype-1.36 {ctype ord tests} { list [catch {ctype ord} msg] $msg } {1 {wrong # args: ctype ?-failindex var? class string}} test chartype-1.37 {ctype ord tests} { ctype ord "" } {0} test chartype-1.38 {ctype ord tests} { ctype ord \377 } [charToNum \377] test chartype-1.39 {ctype ord tests} { ctype ord \277 } [charToNum \277] test chartype-1.40 {ctype ord tests} { ctype char 255 } [numToChar 255] test chartype-1.41 {ctype ord tests} { ctype char 1722 } [numToChar 1722] # cleanup ::tcltest::cleanupTests return tclx8.4-8.4.1.orig/tclconfig/0000755000000000000000000000000012046525461012532 5ustar tclx8.4-8.4.1.orig/tclconfig/tcl.m40000644000000000000000000036171112046525461013567 0ustar # tcl.m4 -- # # This file provides a set of autoconf macros to help TEA-enable # a Tcl extension. # # Copyright (c) 1999-2000 Ajuba Solutions. # Copyright (c) 2002-2005 ActiveState Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # RCS: @(#) $Id: tcl.m4,v 1.15 2006/01/26 00:30:57 hobbs Exp $ AC_PREREQ(2.50) dnl TEA extensions pass this us the version of TEA they think they dnl are compatible with (must be set in TEA_INIT below) dnl TEA_VERSION="3.5" # Possible values for key variables defined: # # TEA_WINDOWINGSYSTEM - win32 aqua x11 (mirrors 'tk windowingsystem') # TEA_PLATFORM - windows unix # #------------------------------------------------------------------------ # TEA_PATH_TCLCONFIG -- # # Locate the tclConfig.sh file and perform a sanity check on # the Tcl compile flags # # Arguments: # none # # Results: # # Adds the following arguments to configure: # --with-tcl=... # # Defines the following vars: # TCL_BIN_DIR Full path to the directory containing # the tclConfig.sh file #------------------------------------------------------------------------ AC_DEFUN(TEA_PATH_TCLCONFIG, [ dnl Make sure we are initialized AC_REQUIRE([TEA_INIT]) # # Ok, lets find the tcl configuration # First, look for one uninstalled. # the alternative search directory is invoked by --with-tcl # if test x"${no_tcl}" = x ; then # we reset no_tcl in case something fails here no_tcl=true AC_ARG_WITH(tcl, AC_HELP_STRING([--with-tcl], [directory containing tcl configuration (tclConfig.sh)]), with_tclconfig=${withval}) AC_MSG_CHECKING([for Tcl configuration]) AC_CACHE_VAL(ac_cv_c_tclconfig,[ # First check to see if --with-tcl was specified. if test x"${with_tclconfig}" != x ; then case ${with_tclconfig} in */tclConfig.sh ) if test -f ${with_tclconfig}; then AC_MSG_WARN([--with-tcl argument should refer to directory containing tclConfig.sh, not to tclConfig.sh itself]) with_tclconfig=`echo ${with_tclconfig} | sed 's!/tclConfig\.sh$!!'` fi ;; esac if test -f "${with_tclconfig}/tclConfig.sh" ; then ac_cv_c_tclconfig=`(cd ${with_tclconfig}; pwd)` else AC_MSG_ERROR([${with_tclconfig} directory doesn't contain tclConfig.sh]) fi fi # then check for a private Tcl installation if test x"${ac_cv_c_tclconfig}" = x ; then for i in \ ../tcl \ `ls -dr ../tcl[[8-9]].[[0-9]].[[0-9]]* 2>/dev/null` \ `ls -dr ../tcl[[8-9]].[[0-9]] 2>/dev/null` \ `ls -dr ../tcl[[8-9]].[[0-9]]* 2>/dev/null` \ ../../tcl \ `ls -dr ../../tcl[[8-9]].[[0-9]].[[0-9]]* 2>/dev/null` \ `ls -dr ../../tcl[[8-9]].[[0-9]] 2>/dev/null` \ `ls -dr ../../tcl[[8-9]].[[0-9]]* 2>/dev/null` \ ../../../tcl \ `ls -dr ../../../tcl[[8-9]].[[0-9]].[[0-9]]* 2>/dev/null` \ `ls -dr ../../../tcl[[8-9]].[[0-9]] 2>/dev/null` \ `ls -dr ../../../tcl[[8-9]].[[0-9]]* 2>/dev/null` ; do if test -f "$i/unix/tclConfig.sh" ; then ac_cv_c_tclconfig=`(cd $i/unix; pwd)` break fi done fi # on Darwin, check in Framework installation locations if test "`uname -s`" = "Darwin" -a x"${ac_cv_c_tclconfig}" = x ; then for i in `ls -d ~/Library/Frameworks 2>/dev/null` \ `ls -d /Library/Frameworks 2>/dev/null` \ `ls -d /Network/Library/Frameworks 2>/dev/null` \ `ls -d /System/Library/Frameworks 2>/dev/null` \ ; do if test -f "$i/Tcl.framework/tclConfig.sh" ; then ac_cv_c_tclconfig=`(cd $i/Tcl.framework; pwd)` break fi done fi # on Windows, check in common installation locations if test "${TEA_PLATFORM}" = "windows" \ -a x"${ac_cv_c_tclconfig}" = x ; then for i in `ls -d C:/Tcl/lib 2>/dev/null` \ `ls -d C:/Progra~1/Tcl/lib 2>/dev/null` \ ; do if test -f "$i/tclConfig.sh" ; then ac_cv_c_tclconfig=`(cd $i; pwd)` break fi done fi # check in a few common install locations if test x"${ac_cv_c_tclconfig}" = x ; then for i in `ls -d ${libdir} 2>/dev/null` \ `ls -d ${exec_prefix}/lib 2>/dev/null` \ `ls -d ${prefix}/lib 2>/dev/null` \ `ls -d /usr/local/lib 2>/dev/null` \ `ls -d /usr/contrib/lib 2>/dev/null` \ `ls -d /usr/lib 2>/dev/null` \ ; do if test -f "$i/tclConfig.sh" ; then ac_cv_c_tclconfig=`(cd $i; pwd)` break fi done fi # check in a few other private locations if test x"${ac_cv_c_tclconfig}" = x ; then for i in \ ${srcdir}/../tcl \ `ls -dr ${srcdir}/../tcl[[8-9]].[[0-9]].[[0-9]]* 2>/dev/null` \ `ls -dr ${srcdir}/../tcl[[8-9]].[[0-9]] 2>/dev/null` \ `ls -dr ${srcdir}/../tcl[[8-9]].[[0-9]]* 2>/dev/null` ; do if test -f "$i/unix/tclConfig.sh" ; then ac_cv_c_tclconfig=`(cd $i/unix; pwd)` break fi done fi ]) if test x"${ac_cv_c_tclconfig}" = x ; then TCL_BIN_DIR="# no Tcl configs found" AC_MSG_WARN([Can't find Tcl configuration definitions]) exit 0 else no_tcl= TCL_BIN_DIR=${ac_cv_c_tclconfig} AC_MSG_RESULT([found ${TCL_BIN_DIR}/tclConfig.sh]) fi fi ]) #------------------------------------------------------------------------ # TEA_PATH_TKCONFIG -- # # Locate the tkConfig.sh file # # Arguments: # none # # Results: # # Adds the following arguments to configure: # --with-tk=... # # Defines the following vars: # TK_BIN_DIR Full path to the directory containing # the tkConfig.sh file #------------------------------------------------------------------------ AC_DEFUN(TEA_PATH_TKCONFIG, [ # # Ok, lets find the tk configuration # First, look for one uninstalled. # the alternative search directory is invoked by --with-tk # if test x"${no_tk}" = x ; then # we reset no_tk in case something fails here no_tk=true AC_ARG_WITH(tk, AC_HELP_STRING([--with-tk], [directory containing tk configuration (tkConfig.sh)]), with_tkconfig=${withval}) AC_MSG_CHECKING([for Tk configuration]) AC_CACHE_VAL(ac_cv_c_tkconfig,[ # First check to see if --with-tkconfig was specified. if test x"${with_tkconfig}" != x ; then case ${with_tkconfig} in */tkConfig.sh ) if test -f ${with_tkconfig}; then AC_MSG_WARN([--with-tk argument should refer to directory containing tkConfig.sh, not to tkConfig.sh itself]) with_tkconfig=`echo ${with_tkconfig} | sed 's!/tkConfig\.sh$!!'` fi ;; esac if test -f "${with_tkconfig}/tkConfig.sh" ; then ac_cv_c_tkconfig=`(cd ${with_tkconfig}; pwd)` else AC_MSG_ERROR([${with_tkconfig} directory doesn't contain tkConfig.sh]) fi fi # then check for a private Tk library if test x"${ac_cv_c_tkconfig}" = x ; then for i in \ ../tk \ `ls -dr ../tk[[8-9]].[[0-9]].[[0-9]]* 2>/dev/null` \ `ls -dr ../tk[[8-9]].[[0-9]] 2>/dev/null` \ `ls -dr ../tk[[8-9]].[[0-9]]* 2>/dev/null` \ ../../tk \ `ls -dr ../../tk[[8-9]].[[0-9]].[[0-9]]* 2>/dev/null` \ `ls -dr ../../tk[[8-9]].[[0-9]] 2>/dev/null` \ `ls -dr ../../tk[[8-9]].[[0-9]]* 2>/dev/null` \ ../../../tk \ `ls -dr ../../../tk[[8-9]].[[0-9]].[[0-9]]* 2>/dev/null` \ `ls -dr ../../../tk[[8-9]].[[0-9]] 2>/dev/null` \ `ls -dr ../../../tk[[8-9]].[[0-9]]* 2>/dev/null` ; do if test -f "$i/unix/tkConfig.sh" ; then ac_cv_c_tkconfig=`(cd $i/unix; pwd)` break fi done fi # on Darwin, check in Framework installation locations if test "`uname -s`" = "Darwin" -a x"${ac_cv_c_tkconfig}" = x ; then for i in `ls -d ~/Library/Frameworks 2>/dev/null` \ `ls -d /Library/Frameworks 2>/dev/null` \ `ls -d /Network/Library/Frameworks 2>/dev/null` \ `ls -d /System/Library/Frameworks 2>/dev/null` \ ; do if test -f "$i/Tk.framework/tkConfig.sh" ; then ac_cv_c_tkconfig=`(cd $i/Tk.framework; pwd)` break fi done fi # check in a few common install locations if test x"${ac_cv_c_tkconfig}" = x ; then for i in `ls -d ${libdir} 2>/dev/null` \ `ls -d ${exec_prefix}/lib 2>/dev/null` \ `ls -d ${prefix}/lib 2>/dev/null` \ `ls -d /usr/local/lib 2>/dev/null` \ `ls -d /usr/contrib/lib 2>/dev/null` \ `ls -d /usr/lib 2>/dev/null` \ ; do if test -f "$i/tkConfig.sh" ; then ac_cv_c_tkconfig=`(cd $i; pwd)` break fi done fi # on Windows, check in common installation locations if test "${TEA_PLATFORM}" = "windows" \ -a x"${ac_cv_c_tclconfig}" = x ; then for i in `ls -d C:/Tcl/lib 2>/dev/null` \ `ls -d C:/Progra~1/Tcl/lib 2>/dev/null` \ ; do if test -f "$i/tclConfig.sh" ; then ac_cv_c_tclconfig=`(cd $i; pwd)` break fi done fi # check in a few other private locations if test x"${ac_cv_c_tkconfig}" = x ; then for i in \ ${srcdir}/../tk \ `ls -dr ${srcdir}/../tk[[8-9]].[[0-9]].[[0-9]]* 2>/dev/null` \ `ls -dr ${srcdir}/../tk[[8-9]].[[0-9]] 2>/dev/null` \ `ls -dr ${srcdir}/../tk[[8-9]].[[0-9]]* 2>/dev/null` ; do if test -f "$i/unix/tkConfig.sh" ; then ac_cv_c_tkconfig=`(cd $i/unix; pwd)` break fi done fi ]) if test x"${ac_cv_c_tkconfig}" = x ; then TK_BIN_DIR="# no Tk configs found" AC_MSG_WARN([Can't find Tk configuration definitions]) exit 0 else no_tk= TK_BIN_DIR=${ac_cv_c_tkconfig} AC_MSG_RESULT([found ${TK_BIN_DIR}/tkConfig.sh]) fi fi ]) #------------------------------------------------------------------------ # TEA_LOAD_TCLCONFIG -- # # Load the tclConfig.sh file # # Arguments: # # Requires the following vars to be set: # TCL_BIN_DIR # # Results: # # Subst the following vars: # TCL_BIN_DIR # TCL_SRC_DIR # TCL_LIB_FILE # #------------------------------------------------------------------------ AC_DEFUN(TEA_LOAD_TCLCONFIG, [ AC_MSG_CHECKING([for existence of ${TCL_BIN_DIR}/tclConfig.sh]) if test -f "${TCL_BIN_DIR}/tclConfig.sh" ; then AC_MSG_RESULT([loading]) . ${TCL_BIN_DIR}/tclConfig.sh else AC_MSG_RESULT([could not find ${TCL_BIN_DIR}/tclConfig.sh]) fi # eval is required to do the TCL_DBGX substitution eval "TCL_LIB_FILE=\"${TCL_LIB_FILE}\"" eval "TCL_STUB_LIB_FILE=\"${TCL_STUB_LIB_FILE}\"" # If the TCL_BIN_DIR is the build directory (not the install directory), # then set the common variable name to the value of the build variables. # For example, the variable TCL_LIB_SPEC will be set to the value # of TCL_BUILD_LIB_SPEC. An extension should make use of TCL_LIB_SPEC # instead of TCL_BUILD_LIB_SPEC since it will work with both an # installed and uninstalled version of Tcl. if test -f ${TCL_BIN_DIR}/Makefile ; then TCL_LIB_SPEC=${TCL_BUILD_LIB_SPEC} TCL_STUB_LIB_SPEC=${TCL_BUILD_STUB_LIB_SPEC} TCL_STUB_LIB_PATH=${TCL_BUILD_STUB_LIB_PATH} elif test "`uname -s`" = "Darwin"; then # If Tcl was built as a framework, attempt to use the libraries # from the framework at the given location so that linking works # against Tcl.framework installed in an arbitary location. case ${TCL_DEFS} in *TCL_FRAMEWORK*) if test -f ${TCL_BIN_DIR}/${TCL_LIB_FILE}; then for i in "`cd ${TCL_BIN_DIR}; pwd`" \ "`cd ${TCL_BIN_DIR}/../..; pwd`"; do if test "`basename "$i"`" = "${TCL_LIB_FILE}.framework"; then TCL_LIB_SPEC="-F`dirname "$i"` -framework ${TCL_LIB_FILE}" break fi done fi if test -f ${TCL_BIN_DIR}/${TCL_STUB_LIB_FILE}; then TCL_STUB_LIB_SPEC="-L${TCL_BIN_DIR} ${TCL_STUB_LIB_FLAG}" TCL_STUB_LIB_PATH="${TCL_BIN_DIR}/${TCL_STUB_LIB_FILE}" fi ;; esac fi # eval is required to do the TCL_DBGX substitution eval "TCL_LIB_FLAG=\"${TCL_LIB_FLAG}\"" eval "TCL_LIB_SPEC=\"${TCL_LIB_SPEC}\"" eval "TCL_STUB_LIB_FLAG=\"${TCL_STUB_LIB_FLAG}\"" eval "TCL_STUB_LIB_SPEC=\"${TCL_STUB_LIB_SPEC}\"" AC_SUBST(TCL_VERSION) AC_SUBST(TCL_BIN_DIR) AC_SUBST(TCL_SRC_DIR) AC_SUBST(TCL_LIB_FILE) AC_SUBST(TCL_LIB_FLAG) AC_SUBST(TCL_LIB_SPEC) AC_SUBST(TCL_STUB_LIB_FILE) AC_SUBST(TCL_STUB_LIB_FLAG) AC_SUBST(TCL_STUB_LIB_SPEC) AC_SUBST(TCL_LIBS) AC_SUBST(TCL_DEFS) AC_SUBST(TCL_EXTRA_CFLAGS) AC_SUBST(TCL_LD_FLAGS) AC_SUBST(TCL_SHLIB_LD_LIBS) ]) #------------------------------------------------------------------------ # TEA_LOAD_TKCONFIG -- # # Load the tkConfig.sh file # # Arguments: # # Requires the following vars to be set: # TK_BIN_DIR # # Results: # # Sets the following vars that should be in tkConfig.sh: # TK_BIN_DIR #------------------------------------------------------------------------ AC_DEFUN(TEA_LOAD_TKCONFIG, [ AC_MSG_CHECKING([for existence of ${TK_BIN_DIR}/tkConfig.sh]) if test -f "${TK_BIN_DIR}/tkConfig.sh" ; then AC_MSG_RESULT([loading]) . ${TK_BIN_DIR}/tkConfig.sh else AC_MSG_RESULT([could not find ${TK_BIN_DIR}/tkConfig.sh]) fi # eval is required to do the TK_DBGX substitution eval "TK_LIB_FILE=\"${TK_LIB_FILE}\"" eval "TK_STUB_LIB_FILE=\"${TK_STUB_LIB_FILE}\"" # If the TK_BIN_DIR is the build directory (not the install directory), # then set the common variable name to the value of the build variables. # For example, the variable TK_LIB_SPEC will be set to the value # of TK_BUILD_LIB_SPEC. An extension should make use of TK_LIB_SPEC # instead of TK_BUILD_LIB_SPEC since it will work with both an # installed and uninstalled version of Tcl. if test -f ${TK_BIN_DIR}/Makefile ; then TK_LIB_SPEC=${TK_BUILD_LIB_SPEC} TK_STUB_LIB_SPEC=${TK_BUILD_STUB_LIB_SPEC} TK_STUB_LIB_PATH=${TK_BUILD_STUB_LIB_PATH} elif test "`uname -s`" = "Darwin"; then # If Tk was built as a framework, attempt to use the libraries # from the framework at the given location so that linking works # against Tk.framework installed in an arbitary location. case ${TK_DEFS} in *TK_FRAMEWORK*) if test -f ${TK_BIN_DIR}/${TK_LIB_FILE}; then for i in "`cd ${TK_BIN_DIR}; pwd`" \ "`cd ${TK_BIN_DIR}/../..; pwd`"; do if test "`basename "$i"`" = "${TK_LIB_FILE}.framework"; then TK_LIB_SPEC="-F`dirname "$i"` -framework ${TK_LIB_FILE}" break fi done fi if test -f ${TK_BIN_DIR}/${TK_STUB_LIB_FILE}; then TK_STUB_LIB_SPEC="-L${TK_BIN_DIR} ${TK_STUB_LIB_FLAG}" TK_STUB_LIB_PATH="${TK_BIN_DIR}/${TK_STUB_LIB_FILE}" fi ;; esac fi # eval is required to do the TK_DBGX substitution eval "TK_LIB_FLAG=\"${TK_LIB_FLAG}\"" eval "TK_LIB_SPEC=\"${TK_LIB_SPEC}\"" eval "TK_STUB_LIB_FLAG=\"${TK_STUB_LIB_FLAG}\"" eval "TK_STUB_LIB_SPEC=\"${TK_STUB_LIB_SPEC}\"" # Ensure windowingsystem is defined if test "${TEA_PLATFORM}" = "unix" ; then case ${TK_DEFS} in *MAC_OSX_TK*) AC_DEFINE(MAC_OSX_TK, 1, [Are we building against Mac OS X TkAqua?]) TEA_WINDOWINGSYSTEM="aqua" ;; *) TEA_WINDOWINGSYSTEM="x11" ;; esac elif test "${TEA_PLATFORM}" = "windows" ; then TEA_WINDOWINGSYSTEM="win32" fi AC_SUBST(TK_VERSION) AC_SUBST(TK_BIN_DIR) AC_SUBST(TK_SRC_DIR) AC_SUBST(TK_LIB_FILE) AC_SUBST(TK_LIB_FLAG) AC_SUBST(TK_LIB_SPEC) AC_SUBST(TK_STUB_LIB_FILE) AC_SUBST(TK_STUB_LIB_FLAG) AC_SUBST(TK_STUB_LIB_SPEC) AC_SUBST(TK_LIBS) AC_SUBST(TK_XINCLUDES) ]) #------------------------------------------------------------------------ # TEA_ENABLE_SHARED -- # # Allows the building of shared libraries # # Arguments: # none # # Results: # # Adds the following arguments to configure: # --enable-shared=yes|no # # Defines the following vars: # STATIC_BUILD Used for building import/export libraries # on Windows. # # Sets the following vars: # SHARED_BUILD Value of 1 or 0 #------------------------------------------------------------------------ AC_DEFUN(TEA_ENABLE_SHARED, [ AC_MSG_CHECKING([how to build libraries]) AC_ARG_ENABLE(shared, AC_HELP_STRING([--enable-shared], [build and link with shared libraries (default: on)]), [tcl_ok=$enableval], [tcl_ok=yes]) if test "${enable_shared+set}" = set; then enableval="$enable_shared" tcl_ok=$enableval else tcl_ok=yes fi if test "$tcl_ok" = "yes" ; then AC_MSG_RESULT([shared]) SHARED_BUILD=1 else AC_MSG_RESULT([static]) SHARED_BUILD=0 AC_DEFINE(STATIC_BUILD, 1, [Is this a static build?]) fi AC_SUBST(SHARED_BUILD) ]) #------------------------------------------------------------------------ # TEA_ENABLE_THREADS -- # # Specify if thread support should be enabled. If "yes" is specified # as an arg (optional), threads are enabled by default, "no" means # threads are disabled. "yes" is the default. # # TCL_THREADS is checked so that if you are compiling an extension # against a threaded core, your extension must be compiled threaded # as well. # # Note that it is legal to have a thread enabled extension run in a # threaded or non-threaded Tcl core, but a non-threaded extension may # only run in a non-threaded Tcl core. # # Arguments: # none # # Results: # # Adds the following arguments to configure: # --enable-threads # # Sets the following vars: # THREADS_LIBS Thread library(s) # # Defines the following vars: # TCL_THREADS # _REENTRANT # _THREAD_SAFE # #------------------------------------------------------------------------ AC_DEFUN(TEA_ENABLE_THREADS, [ AC_ARG_ENABLE(threads, AC_HELP_STRING([--enable-threads], [build with threads]), [tcl_ok=$enableval], [tcl_ok=yes]) if test "${enable_threads+set}" = set; then enableval="$enable_threads" tcl_ok=$enableval else tcl_ok=yes fi if test "$tcl_ok" = "yes" -o "${TCL_THREADS}" = 1; then TCL_THREADS=1 if test "${TEA_PLATFORM}" != "windows" ; then # We are always OK on Windows, so check what this platform wants: # USE_THREAD_ALLOC tells us to try the special thread-based # allocator that significantly reduces lock contention AC_DEFINE(USE_THREAD_ALLOC, 1, [Do we want to use the threaded memory allocator?]) AC_DEFINE(_REENTRANT, 1, [Do we want the reentrant OS API?]) if test "`uname -s`" = "SunOS" ; then AC_DEFINE(_POSIX_PTHREAD_SEMANTICS, 1, [Do we really want to follow the standard? Yes we do!]) fi AC_DEFINE(_THREAD_SAFE, 1, [Do we want the thread-safe OS API?]) AC_CHECK_LIB(pthread,pthread_mutex_init,tcl_ok=yes,tcl_ok=no) if test "$tcl_ok" = "no"; then # Check a little harder for __pthread_mutex_init in the same # library, as some systems hide it there until pthread.h is # defined. We could alternatively do an AC_TRY_COMPILE with # pthread.h, but that will work with libpthread really doesn't # exist, like AIX 4.2. [Bug: 4359] AC_CHECK_LIB(pthread, __pthread_mutex_init, tcl_ok=yes, tcl_ok=no) fi if test "$tcl_ok" = "yes"; then # The space is needed THREADS_LIBS=" -lpthread" else AC_CHECK_LIB(pthreads, pthread_mutex_init, tcl_ok=yes, tcl_ok=no) if test "$tcl_ok" = "yes"; then # The space is needed THREADS_LIBS=" -lpthreads" else AC_CHECK_LIB(c, pthread_mutex_init, tcl_ok=yes, tcl_ok=no) if test "$tcl_ok" = "no"; then AC_CHECK_LIB(c_r, pthread_mutex_init, tcl_ok=yes, tcl_ok=no) if test "$tcl_ok" = "yes"; then # The space is needed THREADS_LIBS=" -pthread" else TCL_THREADS=0 AC_MSG_WARN([Do not know how to find pthread lib on your system - thread support disabled]) fi fi fi fi fi else TCL_THREADS=0 fi # Do checking message here to not mess up interleaved configure output AC_MSG_CHECKING([for building with threads]) if test "${TCL_THREADS}" = 1; then AC_DEFINE(TCL_THREADS, 1, [Are we building with threads enabled?]) AC_MSG_RESULT([yes (default)]) else AC_MSG_RESULT([no]) fi # TCL_THREADS sanity checking. See if our request for building with # threads is the same as the way Tcl was built. If not, warn the user. case ${TCL_DEFS} in *THREADS=1*) if test "${TCL_THREADS}" = "0"; then AC_MSG_WARN([ Building ${PACKAGE_NAME} without threads enabled, but building against Tcl that IS thread-enabled. It is recommended to use --enable-threads.]) fi ;; *) if test "${TCL_THREADS}" = "1"; then AC_MSG_WARN([ --enable-threads requested, but building against a Tcl that is NOT thread-enabled. This is an OK configuration that will also run in a thread-enabled core.]) fi ;; esac AC_SUBST(TCL_THREADS) ]) #------------------------------------------------------------------------ # TEA_ENABLE_SYMBOLS -- # # Specify if debugging symbols should be used. # Memory (TCL_MEM_DEBUG) debugging can also be enabled. # # Arguments: # none # # TEA varies from core Tcl in that C|LDFLAGS_DEFAULT receives # the value of C|LDFLAGS_OPTIMIZE|DEBUG already substituted. # Requires the following vars to be set in the Makefile: # CFLAGS_DEFAULT # LDFLAGS_DEFAULT # # Results: # # Adds the following arguments to configure: # --enable-symbols # # Defines the following vars: # CFLAGS_DEFAULT Sets to $(CFLAGS_DEBUG) if true # Sets to $(CFLAGS_OPTIMIZE) if false # LDFLAGS_DEFAULT Sets to $(LDFLAGS_DEBUG) if true # Sets to $(LDFLAGS_OPTIMIZE) if false # DBGX Formerly used as debug library extension; # always blank now. # #------------------------------------------------------------------------ AC_DEFUN(TEA_ENABLE_SYMBOLS, [ dnl Make sure we are initialized AC_REQUIRE([TEA_CONFIG_CFLAGS]) AC_MSG_CHECKING([for build with symbols]) AC_ARG_ENABLE(symbols, AC_HELP_STRING([--enable-symbols], [build with debugging symbols (default: off)]), [tcl_ok=$enableval], [tcl_ok=no]) DBGX="" if test "$tcl_ok" = "no"; then CFLAGS_DEFAULT="${CFLAGS_OPTIMIZE}" LDFLAGS_DEFAULT="${LDFLAGS_OPTIMIZE}" AC_MSG_RESULT([no]) else CFLAGS_DEFAULT="${CFLAGS_DEBUG}" LDFLAGS_DEFAULT="${LDFLAGS_DEBUG}" if test "$tcl_ok" = "yes"; then AC_MSG_RESULT([yes (standard debugging)]) fi fi if test "${TEA_PLATFORM}" != "windows" ; then LDFLAGS_DEFAULT="${LDFLAGS}" fi AC_SUBST(TCL_DBGX) AC_SUBST(CFLAGS_DEFAULT) AC_SUBST(LDFLAGS_DEFAULT) if test "$tcl_ok" = "mem" -o "$tcl_ok" = "all"; then AC_DEFINE(TCL_MEM_DEBUG, 1, [Is memory debugging enabled?]) fi if test "$tcl_ok" != "yes" -a "$tcl_ok" != "no"; then if test "$tcl_ok" = "all"; then AC_MSG_RESULT([enabled symbols mem debugging]) else AC_MSG_RESULT([enabled $tcl_ok debugging]) fi fi ]) #------------------------------------------------------------------------ # TEA_ENABLE_LANGINFO -- # # Allows use of modern nl_langinfo check for better l10n. # This is only relevant for Unix. # # Arguments: # none # # Results: # # Adds the following arguments to configure: # --enable-langinfo=yes|no (default is yes) # # Defines the following vars: # HAVE_LANGINFO Triggers use of nl_langinfo if defined. # #------------------------------------------------------------------------ AC_DEFUN(TEA_ENABLE_LANGINFO, [ AC_ARG_ENABLE(langinfo, AC_HELP_STRING([--enable-langinfo], [use nl_langinfo if possible to determine encoding at startup, otherwise use old heuristic (default: on)]), [langinfo_ok=$enableval], [langinfo_ok=yes]) HAVE_LANGINFO=0 if test "$langinfo_ok" = "yes"; then AC_CHECK_HEADER(langinfo.h,[langinfo_ok=yes],[langinfo_ok=no]) fi AC_MSG_CHECKING([whether to use nl_langinfo]) if test "$langinfo_ok" = "yes"; then AC_CACHE_VAL(tcl_cv_langinfo_h, AC_TRY_COMPILE([#include ], [nl_langinfo(CODESET);], [tcl_cv_langinfo_h=yes],[tcl_cv_langinfo_h=no])) AC_MSG_RESULT([$tcl_cv_langinfo_h]) if test $tcl_cv_langinfo_h = yes; then AC_DEFINE(HAVE_LANGINFO, 1, [Do we have nl_langinfo()?]) fi else AC_MSG_RESULT([$langinfo_ok]) fi ]) #-------------------------------------------------------------------- # TEA_CONFIG_SYSTEM # # Determine what the system is (some things cannot be easily checked # on a feature-driven basis, alas). This can usually be done via the # "uname" command, but there are a few systems, like Next, where # this doesn't work. # # Arguments: # none # # Results: # Defines the following var: # # system - System/platform/version identification code. # #-------------------------------------------------------------------- AC_DEFUN(TEA_CONFIG_SYSTEM, [ AC_CACHE_CHECK([system version], tcl_cv_sys_version, [ if test "${TEA_PLATFORM}" = "windows" ; then tcl_cv_sys_version=windows elif test -f /usr/lib/NextStep/software_version; then tcl_cv_sys_version=NEXTSTEP-`awk '/3/,/3/' /usr/lib/NextStep/software_version` else tcl_cv_sys_version=`uname -s`-`uname -r` if test "$?" -ne 0 ; then AC_MSG_WARN([can't find uname command]) tcl_cv_sys_version=unknown else # Special check for weird MP-RAS system (uname returns weird # results, and the version is kept in special file). if test -r /etc/.relid -a "X`uname -n`" = "X`uname -s`" ; then tcl_cv_sys_version=MP-RAS-`awk '{print $3}' /etc/.relid` fi if test "`uname -s`" = "AIX" ; then tcl_cv_sys_version=AIX-`uname -v`.`uname -r` fi fi fi ]) system=$tcl_cv_sys_version ]) #-------------------------------------------------------------------- # TEA_CONFIG_CFLAGS # # Try to determine the proper flags to pass to the compiler # for building shared libraries and other such nonsense. # # Arguments: # none # # Results: # # Defines and substitutes the following vars: # # DL_OBJS - Name of the object file that implements dynamic # loading for Tcl on this system. # DL_LIBS - Library file(s) to include in tclsh and other base # applications in order for the "load" command to work. # LDFLAGS - Flags to pass to the compiler when linking object # files into an executable application binary such # as tclsh. # LD_SEARCH_FLAGS-Flags to pass to ld, such as "-R /usr/local/tcl/lib", # that tell the run-time dynamic linker where to look # for shared libraries such as libtcl.so. Depends on # the variable LIB_RUNTIME_DIR in the Makefile. Could # be the same as CC_SEARCH_FLAGS if ${CC} is used to link. # CC_SEARCH_FLAGS-Flags to pass to ${CC}, such as "-Wl,-rpath,/usr/local/tcl/lib", # that tell the run-time dynamic linker where to look # for shared libraries such as libtcl.so. Depends on # the variable LIB_RUNTIME_DIR in the Makefile. # SHLIB_CFLAGS - Flags to pass to cc when compiling the components # of a shared library (may request position-independent # code, among other things). # SHLIB_LD - Base command to use for combining object files # into a shared library. # SHLIB_LD_LIBS - Dependent libraries for the linker to scan when # creating shared libraries. This symbol typically # goes at the end of the "ld" commands that build # shared libraries. The value of the symbol is # "${LIBS}" if all of the dependent libraries should # be specified when creating a shared library. If # dependent libraries should not be specified (as on # SunOS 4.x, where they cause the link to fail, or in # general if Tcl and Tk aren't themselves shared # libraries), then this symbol has an empty string # as its value. # SHLIB_SUFFIX - Suffix to use for the names of dynamically loadable # extensions. An empty string means we don't know how # to use shared libraries on this platform. # LIB_SUFFIX - Specifies everything that comes after the "libfoo" # in a static or shared library name, using the $VERSION variable # to put the version in the right place. This is used # by platforms that need non-standard library names. # Examples: ${VERSION}.so.1.1 on NetBSD, since it needs # to have a version after the .so, and ${VERSION}.a # on AIX, since a shared library needs to have # a .a extension whereas shared objects for loadable # extensions have a .so extension. Defaults to # ${VERSION}${SHLIB_SUFFIX}. # TCL_NEEDS_EXP_FILE - # 1 means that an export file is needed to link to a # shared library. # TCL_EXP_FILE - The name of the installed export / import file which # should be used to link to the Tcl shared library. # Empty if Tcl is unshared. # TCL_BUILD_EXP_FILE - # The name of the built export / import file which # should be used to link to the Tcl shared library. # Empty if Tcl is unshared. # CFLAGS_DEBUG - # Flags used when running the compiler in debug mode # CFLAGS_OPTIMIZE - # Flags used when running the compiler in optimize mode # CFLAGS - Additional CFLAGS added as necessary (usually 64-bit) # #-------------------------------------------------------------------- AC_DEFUN(TEA_CONFIG_CFLAGS, [ dnl Make sure we are initialized AC_REQUIRE([TEA_INIT]) # Step 0.a: Enable 64 bit support? AC_MSG_CHECKING([if 64bit support is requested]) AC_ARG_ENABLE(64bit, AC_HELP_STRING([--enable-64bit], [enable 64bit support (default: off)]), [do64bit=$enableval], [do64bit=no]) AC_MSG_RESULT([$do64bit]) # Step 0.b: Enable Solaris 64 bit VIS support? AC_MSG_CHECKING([if 64bit Sparc VIS support is requested]) AC_ARG_ENABLE(64bit-vis, AC_HELP_STRING([--enable-64bit-vis], [enable 64bit Sparc VIS support (default: off)]), [do64bitVIS=$enableval], [do64bitVIS=no]) AC_MSG_RESULT([$do64bitVIS]) if test "$do64bitVIS" = "yes"; then # Force 64bit on with VIS do64bit=yes fi # Step 0.c: Cross-compiling options for Windows/CE builds? if test "${TEA_PLATFORM}" = "windows" ; then AC_MSG_CHECKING([if Windows/CE build is requested]) AC_ARG_ENABLE(wince,[ --enable-wince enable Win/CE support (where applicable)], [doWince=$enableval], [doWince=no]) AC_MSG_RESULT([$doWince]) fi # Step 1: set the variable "system" to hold the name and version number # for the system. TEA_CONFIG_SYSTEM # Step 2: check for existence of -ldl library. This is needed because # Linux can use either -ldl or -ldld for dynamic loading. AC_CHECK_LIB(dl, dlopen, have_dl=yes, have_dl=no) # Require ranlib early so we can override it in special cases below. AC_REQUIRE([AC_PROG_RANLIB]) # Step 3: set configuration options based on system name and version. # This is similar to Tcl's unix/tcl.m4 except that we've added a # "windows" case. do64bit_ok=no LDFLAGS_ORIG="$LDFLAGS" # When ld needs options to work in 64-bit mode, put them in # LDFLAGS_ARCH so they eventually end up in LDFLAGS even if [load] # is disabled by the user. [Bug 1016796] LDFLAGS_ARCH="" TCL_EXPORT_FILE_SUFFIX="" UNSHARED_LIB_SUFFIX="" TCL_TRIM_DOTS='`echo ${PACKAGE_VERSION} | tr -d .`' ECHO_VERSION='`echo ${PACKAGE_VERSION}`' TCL_LIB_VERSIONS_OK=ok CFLAGS_DEBUG=-g CFLAGS_OPTIMIZE=-O if test "$GCC" = "yes" ; then CFLAGS_OPTIMIZE=-O2 CFLAGS_WARNING="-Wall -Wno-implicit-int" else CFLAGS_WARNING="" fi TCL_NEEDS_EXP_FILE=0 TCL_BUILD_EXP_FILE="" TCL_EXP_FILE="" dnl FIXME: Replace AC_CHECK_PROG with AC_CHECK_TOOL once cross compiling is fixed. dnl AC_CHECK_TOOL(AR, ar) AC_CHECK_PROG(AR, ar, ar) STLIB_LD='${AR} cr' LD_LIBRARY_PATH_VAR="LD_LIBRARY_PATH" case $system in windows) # This is a 2-stage check to make sure we have the 64-bit SDK # We have to know where the SDK is installed. # This magic is based on MS Platform SDK for Win2003 SP1 - hobbs # MACHINE is IX86 for LINK, but this is used by the manifest, # which requires x86|amd64|ia64. MACHINE="X86" if test "$do64bit" != "no" ; then if test "x${MSSDK}x" = "xx" ; then MSSDK="C:/Progra~1/Microsoft Platform SDK" fi MSSDK=`echo "$MSSDK" | sed -e 's!\\\!/!g'` PATH64="" case "$do64bit" in amd64|x64|yes) MACHINE="AMD64" ; # default to AMD64 64-bit build PATH64="${MSSDK}/Bin/Win64/x86/AMD64" ;; ia64) MACHINE="IA64" PATH64="${MSSDK}/Bin/Win64" ;; esac if test ! -d "${PATH64}" ; then AC_MSG_WARN([Could not find 64-bit $MACHINE SDK to enable 64bit mode]) AC_MSG_WARN([Ensure latest Platform SDK is installed]) do64bit="no" else AC_MSG_RESULT([ Using 64-bit $MACHINE mode]) do64bit_ok="yes" fi fi if test "$doWince" != "no" ; then if test "$do64bit" != "no" ; then AC_MSG_ERROR([Windows/CE and 64-bit builds incompatible]) fi if test "$GCC" = "yes" ; then AC_MSG_ERROR([Windows/CE and GCC builds incompatible]) fi TEA_PATH_CELIB # Set defaults for common evc4/PPC2003 setup # Currently Tcl requires 300+, possibly 420+ for sockets CEVERSION=420; # could be 211 300 301 400 420 ... TARGETCPU=ARMV4; # could be ARMV4 ARM MIPS SH3 X86 ... ARCH=ARM; # could be ARM MIPS X86EM ... PLATFORM="Pocket PC 2003"; # or "Pocket PC 2002" if test "$doWince" != "yes"; then # If !yes then the user specified something # Reset ARCH to allow user to skip specifying it ARCH= eval `echo $doWince | awk -F, '{ \ if (length([$]1)) { printf "CEVERSION=\"%s\"\n", [$]1; \ if ([$]1 < 400) { printf "PLATFORM=\"Pocket PC 2002\"\n" } }; \ if (length([$]2)) { printf "TARGETCPU=\"%s\"\n", toupper([$]2) }; \ if (length([$]3)) { printf "ARCH=\"%s\"\n", toupper([$]3) }; \ if (length([$]4)) { printf "PLATFORM=\"%s\"\n", [$]4 }; \ }'` if test "x${ARCH}" = "x" ; then ARCH=$TARGETCPU; fi fi OSVERSION=WCE$CEVERSION; if test "x${WCEROOT}" = "x" ; then WCEROOT="C:/Program Files/Microsoft eMbedded C++ 4.0" if test ! -d "${WCEROOT}" ; then WCEROOT="C:/Program Files/Microsoft eMbedded Tools" fi fi if test "x${SDKROOT}" = "x" ; then SDKROOT="C:/Program Files/Windows CE Tools" if test ! -d "${SDKROOT}" ; then SDKROOT="C:/Windows CE Tools" fi fi WCEROOT=`echo "$WCEROOT" | sed -e 's!\\\!/!g'` SDKROOT=`echo "$SDKROOT" | sed -e 's!\\\!/!g'` if test ! -d "${SDKROOT}/${OSVERSION}/${PLATFORM}/Lib/${TARGETCPU}" \ -o ! -d "${WCEROOT}/EVC/${OSVERSION}/bin"; then AC_MSG_ERROR([could not find PocketPC SDK or target compiler to enable WinCE mode [$CEVERSION,$TARGETCPU,$ARCH,$PLATFORM]]) doWince="no" else # We could PATH_NOSPACE these, but that's not important, # as long as we quote them when used. CEINCLUDE="${SDKROOT}/${OSVERSION}/${PLATFORM}/include" if test -d "${CEINCLUDE}/${TARGETCPU}" ; then CEINCLUDE="${CEINCLUDE}/${TARGETCPU}" fi CELIBPATH="${SDKROOT}/${OSVERSION}/${PLATFORM}/Lib/${TARGETCPU}" fi fi if test "$GCC" != "yes" ; then if test "${SHARED_BUILD}" = "0" ; then runtime=-MT else runtime=-MD fi if test "$do64bit" != "no" ; then # All this magic is necessary for the Win64 SDK RC1 - hobbs CC="\"${PATH64}/cl.exe\"" CFLAGS="${CFLAGS} -I\"${MSSDK}/Include\" -I\"${MSSDK}/Include/crt\" -I\"${MSSDK}/Include/crt/sys\"" RC="\"${MSSDK}/bin/rc.exe\"" lflags="-nologo -MACHINE:${MACHINE} -LIBPATH:\"${MSSDK}/Lib/${MACHINE}\"" LINKBIN="\"${PATH64}/link.exe\"" CFLAGS_DEBUG="-nologo -Zi -Od -W3 ${runtime}d" CFLAGS_OPTIMIZE="-nologo -O2 -W2 ${runtime}" # Avoid 'unresolved external symbol __security_cookie' # errors, c.f. http://support.microsoft.com/?id=894573 TEA_ADD_LIBS([bufferoverflowU.lib]) elif test "$doWince" != "no" ; then CEBINROOT="${WCEROOT}/EVC/${OSVERSION}/bin" if test "${TARGETCPU}" = "X86"; then CC="\"${CEBINROOT}/cl.exe\"" else CC="\"${CEBINROOT}/cl${ARCH}.exe\"" fi CFLAGS="$CFLAGS -I\"${CELIB_DIR}/inc\" -I\"${CEINCLUDE}\"" RC="\"${WCEROOT}/Common/EVC/bin/rc.exe\"" arch=`echo ${ARCH} | awk '{print tolower([$]0)}'` defs="${ARCH} _${ARCH}_ ${arch} PALM_SIZE _MT _WINDOWS" if test "${SHARED_BUILD}" = "1" ; then # Static CE builds require static celib as well defs="${defs} _DLL" fi for i in $defs ; do AC_DEFINE_UNQUOTED($i, 1, [WinCE def ]$i) done AC_DEFINE_UNQUOTED(_WIN32_WCE, $CEVERSION, [_WIN32_WCE version]) AC_DEFINE_UNQUOTED(UNDER_CE, $CEVERSION, [UNDER_CE version]) CFLAGS_DEBUG="-nologo -Zi -Od" CFLAGS_OPTIMIZE="-nologo -Ox" lversion=`echo ${CEVERSION} | sed -e 's/\(.\)\(..\)/\1\.\2/'` lflags="-MACHINE:${ARCH} -LIBPATH:\"${CELIBPATH}\" -subsystem:windowsce,${lversion} -nologo" LINKBIN="\"${CEBINROOT}/link.exe\"" AC_SUBST(CELIB_DIR) else RC="rc" lflags="-nologo" LINKBIN="link" CFLAGS_DEBUG="-nologo -Z7 -Od -W3 -WX ${runtime}d" CFLAGS_OPTIMIZE="-nologo -O2 -W2 ${runtime}" fi fi if test "$GCC" = "yes"; then # mingw gcc mode RC="windres" CFLAGS_DEBUG="-g" CFLAGS_OPTIMIZE="-O2 -fomit-frame-pointer" SHLIB_LD="$CC -shared" UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.a' LDFLAGS_CONSOLE="-wl,--subsystem,console ${lflags}" LDFLAGS_WINDOW="-wl,--subsystem,windows ${lflags}" else SHLIB_LD="${LINKBIN} -dll ${lflags}" # link -lib only works when -lib is the first arg STLIB_LD="${LINKBIN} -lib ${lflags}" UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.lib' PATHTYPE=-w # For information on what debugtype is most useful, see: # http://msdn.microsoft.com/library/en-us/dnvc60/html/gendepdebug.asp # This essentially turns it all on. LDFLAGS_DEBUG="-debug:full -debugtype:both -warn:2" LDFLAGS_OPTIMIZE="-release" if test "$doWince" != "no" ; then LDFLAGS_CONSOLE="-link ${lflags}" LDFLAGS_WINDOW=${LDFLAGS_CONSOLE} else LDFLAGS_CONSOLE="-link -subsystem:console ${lflags}" LDFLAGS_WINDOW="-link -subsystem:windows ${lflags}" fi fi SHLIB_LD_LIBS='${LIBS}' SHLIB_SUFFIX=".dll" SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.dll' TCL_LIB_VERSIONS_OK=nodots # Bogus to avoid getting this turned off DL_OBJS="tclLoadNone.obj" ;; AIX-*) if test "${TCL_THREADS}" = "1" -a "$GCC" != "yes" ; then # AIX requires the _r compiler when gcc isn't being used case "${CC}" in *_r) # ok ... ;; *) CC=${CC}_r ;; esac AC_MSG_RESULT([Using $CC for compiling with threads]) fi LIBS="$LIBS -lc" SHLIB_CFLAGS="" SHLIB_LD_LIBS='${LIBS}' SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" LD_LIBRARY_PATH_VAR="LIBPATH" # Check to enable 64-bit flags for compiler/linker on AIX 4+ if test "$do64bit" = "yes" -a "`uname -v`" -gt "3" ; then if test "$GCC" = "yes" ; then AC_MSG_WARN([64bit mode not supported with GCC on $system]) else do64bit_ok=yes CFLAGS="$CFLAGS -q64" LDFLAGS_ARCH="-q64" RANLIB="${RANLIB} -X64" AR="${AR} -X64" SHLIB_LD_FLAGS="-b64" fi fi if test "`uname -m`" = "ia64" ; then # AIX-5 uses ELF style dynamic libraries on IA-64, but not PPC SHLIB_LD="/usr/ccs/bin/ld -G -z text" # AIX-5 has dl* in libc.so DL_LIBS="" if test "$GCC" = "yes" ; then CC_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}' else CC_SEARCH_FLAGS='-R${LIB_RUNTIME_DIR}' fi LD_SEARCH_FLAGS='-R ${LIB_RUNTIME_DIR}' else if test "$GCC" = "yes" ; then SHLIB_LD="gcc -shared" else SHLIB_LD="/bin/ld -bhalt:4 -bM:SRE -bE:lib.exp -H512 -T512 -bnoentry" fi SHLIB_LD="${TCL_SRC_DIR}/unix/ldAix ${SHLIB_LD} ${SHLIB_LD_FLAGS}" DL_LIBS="-ldl" CC_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}' LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} TCL_NEEDS_EXP_FILE=1 TCL_EXPORT_FILE_SUFFIX='${PACKAGE_VERSION}.exp' fi # AIX v<=4.1 has some different flags than 4.2+ if test "$system" = "AIX-4.1" -o "`uname -v`" -lt "4" ; then AC_LIBOBJ([tclLoadAix]) DL_LIBS="-lld" fi # On AIX <=v4 systems, libbsd.a has to be linked in to support # non-blocking file IO. This library has to be linked in after # the MATH_LIBS or it breaks the pow() function. The way to # insure proper sequencing, is to add it to the tail of MATH_LIBS. # This library also supplies gettimeofday. # # AIX does not have a timezone field in struct tm. When the AIX # bsd library is used, the timezone global and the gettimeofday # methods are to be avoided for timezone deduction instead, we # deduce the timezone by comparing the localtime result on a # known GMT value. AC_CHECK_LIB(bsd, gettimeofday, libbsd=yes, libbsd=no) if test $libbsd = yes; then MATH_LIBS="$MATH_LIBS -lbsd" AC_DEFINE(USE_DELTA_FOR_TZ, 1, [Do we need a special AIX hack for timezones?]) fi ;; BeOS*) SHLIB_CFLAGS="-fPIC" SHLIB_LD="${CC} -nostart" SHLIB_LD_LIBS='${LIBS}' SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="-ldl" #----------------------------------------------------------- # Check for inet_ntoa in -lbind, for BeOS (which also needs # -lsocket, even if the network functions are in -lnet which # is always linked to, for compatibility. #----------------------------------------------------------- AC_CHECK_LIB(bind, inet_ntoa, [LIBS="$LIBS -lbind -lsocket"]) ;; BSD/OS-2.1*|BSD/OS-3*) SHLIB_CFLAGS="" SHLIB_LD="shlicc -r" SHLIB_LD_LIBS='${LIBS}' SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="-ldl" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; BSD/OS-4.*) SHLIB_CFLAGS="-export-dynamic -fPIC" SHLIB_LD="cc -shared" SHLIB_LD_LIBS='${LIBS}' SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="-ldl" LDFLAGS="$LDFLAGS -export-dynamic" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; dgux*) SHLIB_CFLAGS="-K PIC" SHLIB_LD="cc -G" SHLIB_LD_LIBS="" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="-ldl" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; HP-UX-*.11.*) # Use updated header definitions where possible AC_DEFINE(_XOPEN_SOURCE_EXTENDED, 1, [Do we want to use the XOPEN network library?]) # Needed by Tcl, but not most extensions #AC_DEFINE(_XOPEN_SOURCE, 1, [Do we want to use the XOPEN network library?]) #LIBS="$LIBS -lxnet" # Use the XOPEN network library SHLIB_SUFFIX=".sl" AC_CHECK_LIB(dld, shl_load, tcl_ok=yes, tcl_ok=no) if test "$tcl_ok" = yes; then SHLIB_CFLAGS="+z" SHLIB_LD="ld -b" SHLIB_LD_LIBS='${LIBS}' DL_OBJS="tclLoadShl.o" DL_LIBS="-ldld" LDFLAGS="$LDFLAGS -Wl,-E" CC_SEARCH_FLAGS='-Wl,+s,+b,${LIB_RUNTIME_DIR}:.' LD_SEARCH_FLAGS='+s +b ${LIB_RUNTIME_DIR}:.' LD_LIBRARY_PATH_VAR="SHLIB_PATH" fi if test "$GCC" = "yes" ; then SHLIB_LD="gcc -shared" SHLIB_LD_LIBS='${LIBS}' LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} fi # Users may want PA-RISC 1.1/2.0 portable code - needs HP cc #CFLAGS="$CFLAGS +DAportable" # Check to enable 64-bit flags for compiler/linker if test "$do64bit" = "yes" ; then if test "$GCC" = "yes" ; then hpux_arch=`${CC} -dumpmachine` case $hpux_arch in hppa64*) # 64-bit gcc in use. Fix flags for GNU ld. do64bit_ok=yes SHLIB_LD="${CC} -shared" SHLIB_LD_LIBS='${LIBS}' CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} ;; *) AC_MSG_WARN([64bit mode not supported with GCC on $system]) ;; esac else do64bit_ok=yes CFLAGS="$CFLAGS +DD64" LDFLAGS_ARCH="+DD64" fi fi ;; HP-UX-*.08.*|HP-UX-*.09.*|HP-UX-*.10.*) SHLIB_SUFFIX=".sl" AC_CHECK_LIB(dld, shl_load, tcl_ok=yes, tcl_ok=no) if test "$tcl_ok" = yes; then SHLIB_CFLAGS="+z" SHLIB_LD="ld -b" SHLIB_LD_LIBS="" DL_OBJS="tclLoadShl.o" DL_LIBS="-ldld" LDFLAGS="$LDFLAGS -Wl,-E" CC_SEARCH_FLAGS='-Wl,+s,+b,${LIB_RUNTIME_DIR}:.' LD_SEARCH_FLAGS='+s +b ${LIB_RUNTIME_DIR}:.' LD_LIBRARY_PATH_VAR="SHLIB_PATH" fi ;; IRIX-5.*) SHLIB_CFLAGS="" SHLIB_LD="ld -shared -rdata_shared" SHLIB_LD_LIBS='${LIBS}' SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}' ;; IRIX-6.*) SHLIB_CFLAGS="" SHLIB_LD="ld -n32 -shared -rdata_shared" SHLIB_LD_LIBS='${LIBS}' SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}' if test "$GCC" = "yes" ; then CFLAGS="$CFLAGS -mabi=n32" LDFLAGS="$LDFLAGS -mabi=n32" else case $system in IRIX-6.3) # Use to build 6.2 compatible binaries on 6.3. CFLAGS="$CFLAGS -n32 -D_OLD_TERMIOS" ;; *) CFLAGS="$CFLAGS -n32" ;; esac LDFLAGS="$LDFLAGS -n32" fi ;; IRIX64-6.*) SHLIB_CFLAGS="" SHLIB_LD="ld -n32 -shared -rdata_shared" SHLIB_LD_LIBS='${LIBS}' SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}' # Check to enable 64-bit flags for compiler/linker if test "$do64bit" = "yes" ; then if test "$GCC" = "yes" ; then AC_MSG_WARN([64bit mode not supported by gcc]) else do64bit_ok=yes SHLIB_LD="ld -64 -shared -rdata_shared" CFLAGS="$CFLAGS -64" LDFLAGS_ARCH="-64" fi fi ;; Linux*) SHLIB_CFLAGS="-fPIC" SHLIB_LD_LIBS='${LIBS}' SHLIB_SUFFIX=".so" CFLAGS_OPTIMIZE="-O2 -fomit-frame-pointer" # egcs-2.91.66 on Redhat Linux 6.0 generates lots of warnings # when you inline the string and math operations. Turn this off to # get rid of the warnings. #CFLAGS_OPTIMIZE="${CFLAGS_OPTIMIZE} -D__NO_STRING_INLINES -D__NO_MATH_INLINES" SHLIB_LD="${CC} -shared" DL_OBJS="tclLoadDl.o" DL_LIBS="-ldl" LDFLAGS="$LDFLAGS -Wl,--export-dynamic" CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} if test "`uname -m`" = "alpha" ; then CFLAGS="$CFLAGS -mieee" fi # The combo of gcc + glibc has a bug related # to inlining of functions like strtod(). The # -fno-builtin flag should address this problem # but it does not work. The -fno-inline flag # is kind of overkill but it works. # Disable inlining only when one of the # files in compat/*.c is being linked in. if test x"${USE_COMPAT}" != x ; then CFLAGS="$CFLAGS -fno-inline" fi ;; GNU*) SHLIB_CFLAGS="-fPIC" SHLIB_LD_LIBS='${LIBS}' SHLIB_SUFFIX=".so" SHLIB_LD="${CC} -shared" DL_OBJS="" DL_LIBS="-ldl" LDFLAGS="$LDFLAGS -Wl,--export-dynamic" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" if test "`uname -m`" = "alpha" ; then CFLAGS="$CFLAGS -mieee" fi ;; Lynx*) SHLIB_CFLAGS="-fPIC" SHLIB_LD_LIBS='${LIBS}' SHLIB_SUFFIX=".so" CFLAGS_OPTIMIZE=-02 SHLIB_LD="${CC} -shared " DL_OBJS="tclLoadDl.o" DL_LIBS="-mshared -ldl" LD_FLAGS="-Wl,--export-dynamic" CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' LD_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' ;; MP-RAS-02*) SHLIB_CFLAGS="-K PIC" SHLIB_LD="cc -G" SHLIB_LD_LIBS="" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="-ldl" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; MP-RAS-*) SHLIB_CFLAGS="-K PIC" SHLIB_LD="cc -G" SHLIB_LD_LIBS="" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="-ldl" LDFLAGS="$LDFLAGS -Wl,-Bexport" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; NetBSD-*|FreeBSD-[[1-2]].*) # NetBSD/SPARC needs -fPIC, -fpic will not do. SHLIB_CFLAGS="-fPIC" SHLIB_LD="ld -Bshareable -x" SHLIB_LD_LIBS="" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}' AC_CACHE_CHECK([for ELF], tcl_cv_ld_elf, [ AC_EGREP_CPP(yes, [ #ifdef __ELF__ yes #endif ], tcl_cv_ld_elf=yes, tcl_cv_ld_elf=no)]) if test $tcl_cv_ld_elf = yes; then SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.so' else SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.so.1.0' fi # Ancient FreeBSD doesn't handle version numbers with dots. UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.a' TCL_LIB_VERSIONS_OK=nodots ;; OpenBSD-*) # OpenBSD/SPARC[64] needs -fPIC, -fpic will not do. case `machine` in sparc|sparc64) SHLIB_CFLAGS="-fPIC";; *) SHLIB_CFLAGS="-fpic";; esac SHLIB_LD="${CC} -shared ${SHLIB_CFLAGS}" SHLIB_LD_LIBS='${LIBS}' SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.so.1.0' AC_CACHE_CHECK([for ELF], tcl_cv_ld_elf, [ AC_EGREP_CPP(yes, [ #ifdef __ELF__ yes #endif ], tcl_cv_ld_elf=yes, tcl_cv_ld_elf=no)]) if test $tcl_cv_ld_elf = yes; then LDFLAGS=-Wl,-export-dynamic else LDFLAGS="" fi # OpenBSD doesn't do version numbers with dots. UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.a' TCL_LIB_VERSIONS_OK=nodots ;; FreeBSD-*) # FreeBSD 3.* and greater have ELF. SHLIB_CFLAGS="-fPIC" SHLIB_LD="ld -Bshareable -x" SHLIB_LD_LIBS='${LIBS}' SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" LDFLAGS="$LDFLAGS -export-dynamic" CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}' if test "${TCL_THREADS}" = "1" ; then # The -pthread needs to go in the CFLAGS, not LIBS LIBS=`echo $LIBS | sed s/-pthread//` CFLAGS="$CFLAGS -pthread" LDFLAGS="$LDFLAGS -pthread" fi case $system in FreeBSD-3.*) # FreeBSD-3 doesn't handle version numbers with dots. UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.a' SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.so' TCL_LIB_VERSIONS_OK=nodots ;; esac ;; Darwin-*) CFLAGS_OPTIMIZE="-Os" SHLIB_CFLAGS="-fno-common" if test $do64bit = yes; then do64bit_ok=yes CFLAGS="$CFLAGS -arch ppc64 -mpowerpc64 -mcpu=G5" fi # TEA specific: use LDFLAGS_DEFAULT instead of LDFLAGS here: SHLIB_LD='${CC} -dynamiclib ${CFLAGS} ${LDFLAGS_DEFAULT}' AC_CACHE_CHECK([if ld accepts -single_module flag], tcl_cv_ld_single_module, [ hold_ldflags=$LDFLAGS LDFLAGS="$LDFLAGS -dynamiclib -Wl,-single_module" AC_TRY_LINK(, [int i;], tcl_cv_ld_single_module=yes, tcl_cv_ld_single_module=no) LDFLAGS=$hold_ldflags]) if test $tcl_cv_ld_single_module = yes; then SHLIB_LD="${SHLIB_LD} -Wl,-single_module" fi SHLIB_LD_LIBS='${LIBS}' SHLIB_SUFFIX=".dylib" DL_OBJS="tclLoadDyld.o" DL_LIBS="" # Don't use -prebind when building for Mac OS X 10.4 or later only: test -z "${MACOSX_DEPLOYMENT_TARGET}" || \ test "`echo "${MACOSX_DEPLOYMENT_TARGET}" | awk -F. '{print [$]2}'`" -lt 4 && \ LDFLAGS="$LDFLAGS -prebind" LDFLAGS="$LDFLAGS -headerpad_max_install_names" AC_CACHE_CHECK([if ld accepts -search_paths_first flag], tcl_cv_ld_search_paths_first, [ hold_ldflags=$LDFLAGS LDFLAGS="$LDFLAGS -Wl,-search_paths_first" AC_TRY_LINK(, [int i;], tcl_cv_ld_search_paths_first=yes, tcl_cv_ld_search_paths_first=no) LDFLAGS=$hold_ldflags]) if test $tcl_cv_ld_search_paths_first = yes; then LDFLAGS="$LDFLAGS -Wl,-search_paths_first" fi CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" LD_LIBRARY_PATH_VAR="DYLD_LIBRARY_PATH" # TEA specific: for Tk extensions, remove -arch ppc64 from CFLAGS # for fat builds, as neither TkAqua nor TkX11 can be built for 64bit # at present (no 64bit GUI libraries). test $do64bit_ok = no && test -n "${TK_BIN_DIR}" && \ CFLAGS="`echo "$CFLAGS" | sed -e 's/-arch ppc64/-arch ppc/g'`" ;; NEXTSTEP-*) SHLIB_CFLAGS="" SHLIB_LD="cc -nostdlib -r" SHLIB_LD_LIBS="" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadNext.o" DL_LIBS="" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; OS/390-*) CFLAGS_OPTIMIZE="" # Optimizer is buggy AC_DEFINE(_OE_SOCKETS, 1, # needed in sys/socket.h [Should OS/390 do the right thing with sockets?]) ;; OSF1-1.0|OSF1-1.1|OSF1-1.2) # OSF/1 1.[012] from OSF, and derivatives, including Paragon OSF/1 SHLIB_CFLAGS="" # Hack: make package name same as library name SHLIB_LD='ld -R -export $@:' SHLIB_LD_LIBS="" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadOSF.o" DL_LIBS="" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; OSF1-1.*) # OSF/1 1.3 from OSF using ELF, and derivatives, including AD2 SHLIB_CFLAGS="-fPIC" if test "$SHARED_BUILD" = "1" ; then SHLIB_LD="ld -shared" else SHLIB_LD="ld -non_shared" fi SHLIB_LD_LIBS="" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; OSF1-V*) # Digital OSF/1 SHLIB_CFLAGS="" if test "$SHARED_BUILD" = "1" ; then SHLIB_LD='ld -shared -expect_unresolved "*"' else SHLIB_LD='ld -non_shared -expect_unresolved "*"' fi SHLIB_LD_LIBS="" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}' if test "$GCC" = "yes" ; then CFLAGS="$CFLAGS -mieee" else CFLAGS="$CFLAGS -DHAVE_TZSET -std1 -ieee" fi # see pthread_intro(3) for pthread support on osf1, k.furukawa if test "${TCL_THREADS}" = "1" ; then CFLAGS="$CFLAGS -DHAVE_PTHREAD_ATTR_SETSTACKSIZE" CFLAGS="$CFLAGS -DTCL_THREAD_STACK_MIN=PTHREAD_STACK_MIN*64" LIBS=`echo $LIBS | sed s/-lpthreads//` if test "$GCC" = "yes" ; then LIBS="$LIBS -lpthread -lmach -lexc" else CFLAGS="$CFLAGS -pthread" LDFLAGS="$LDFLAGS -pthread" fi fi ;; QNX-6*) # QNX RTP # This may work for all QNX, but it was only reported for v6. SHLIB_CFLAGS="-fPIC" SHLIB_LD="ld -Bshareable -x" SHLIB_LD_LIBS="" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" # dlopen is in -lc on QNX DL_LIBS="" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; SCO_SV-3.2*) # Note, dlopen is available only on SCO 3.2.5 and greater. However, # this test works, since "uname -s" was non-standard in 3.2.4 and # below. if test "$GCC" = "yes" ; then SHLIB_CFLAGS="-fPIC -melf" LDFLAGS="$LDFLAGS -melf -Wl,-Bexport" else SHLIB_CFLAGS="-Kpic -belf" LDFLAGS="$LDFLAGS -belf -Wl,-Bexport" fi SHLIB_LD="ld -G" SHLIB_LD_LIBS="" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; SINIX*5.4*) SHLIB_CFLAGS="-K PIC" SHLIB_LD="cc -G" SHLIB_LD_LIBS="" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="-ldl" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; SunOS-4*) SHLIB_CFLAGS="-PIC" SHLIB_LD="ld" SHLIB_LD_LIBS="" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="-ldl" CC_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}' LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} # SunOS can't handle version numbers with dots in them in library # specs, like -ltcl7.5, so use -ltcl75 instead. Also, it # requires an extra version number at the end of .so file names. # So, the library has to have a name like libtcl75.so.1.0 SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.so.1.0' UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.a' TCL_LIB_VERSIONS_OK=nodots ;; SunOS-5.[[0-6]]) # Careful to not let 5.10+ fall into this case # Note: If _REENTRANT isn't defined, then Solaris # won't define thread-safe library routines. AC_DEFINE(_REENTRANT, 1, [Do we want the reentrant OS API?]) AC_DEFINE(_POSIX_PTHREAD_SEMANTICS, 1, [Do we really want to follow the standard? Yes we do!]) SHLIB_CFLAGS="-KPIC" # Note: need the LIBS below, otherwise Tk won't find Tcl's # symbols when dynamically loaded into tclsh. SHLIB_LD_LIBS='${LIBS}' SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="-ldl" if test "$GCC" = "yes" ; then SHLIB_LD="$CC -shared" CC_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}' LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} else SHLIB_LD="/usr/ccs/bin/ld -G -z text" CC_SEARCH_FLAGS='-R ${LIB_RUNTIME_DIR}' LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} fi ;; SunOS-5*) # Note: If _REENTRANT isn't defined, then Solaris # won't define thread-safe library routines. AC_DEFINE(_REENTRANT, 1, [Do we want the reentrant OS API?]) AC_DEFINE(_POSIX_PTHREAD_SEMANTICS, 1, [Do we really want to follow the standard? Yes we do!]) SHLIB_CFLAGS="-KPIC" # Check to enable 64-bit flags for compiler/linker if test "$do64bit" = "yes" ; then arch=`isainfo` if test "$arch" = "sparcv9 sparc" ; then if test "$GCC" = "yes" ; then if test "`gcc -dumpversion | awk -F. '{print [$]1}'`" -lt "3" ; then AC_MSG_WARN([64bit mode not supported with GCC < 3.2 on $system]) else do64bit_ok=yes CFLAGS="$CFLAGS -m64 -mcpu=v9" LDFLAGS="$LDFLAGS -m64 -mcpu=v9" SHLIB_CFLAGS="-fPIC" fi else do64bit_ok=yes if test "$do64bitVIS" = "yes" ; then CFLAGS="$CFLAGS -xarch=v9a" LDFLAGS_ARCH="-xarch=v9a" else CFLAGS="$CFLAGS -xarch=v9" LDFLAGS_ARCH="-xarch=v9" fi # Solaris 64 uses this as well #LD_LIBRARY_PATH_VAR="LD_LIBRARY_PATH_64" fi elif test "$arch" = "amd64 i386" ; then if test "$GCC" = "yes" ; then AC_MSG_WARN([64bit mode not supported with GCC on $system]) else do64bit_ok=yes CFLAGS="$CFLAGS -xarch=amd64" LDFLAGS="$LDFLAGS -xarch=amd64" fi else AC_MSG_WARN([64bit mode not supported for $arch]) fi fi # Note: need the LIBS below, otherwise Tk won't find Tcl's # symbols when dynamically loaded into tclsh. SHLIB_LD_LIBS='${LIBS}' SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="-ldl" if test "$GCC" = "yes" ; then SHLIB_LD="$CC -shared" CC_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}' LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} if test "$do64bit_ok" = "yes" ; then # We need to specify -static-libgcc or we need to # add the path to the sparv9 libgcc. # JH: static-libgcc is necessary for core Tcl, but may # not be necessary for extensions. SHLIB_LD="$SHLIB_LD -m64 -mcpu=v9 -static-libgcc" # for finding sparcv9 libgcc, get the regular libgcc # path, remove so name and append 'sparcv9' #v9gcclibdir="`gcc -print-file-name=libgcc_s.so` | ..." #CC_SEARCH_FLAGS="${CC_SEARCH_FLAGS},-R,$v9gcclibdir" fi else SHLIB_LD="/usr/ccs/bin/ld -G -z text" CC_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}' LD_SEARCH_FLAGS='-R ${LIB_RUNTIME_DIR}' fi ;; UNIX_SV* | UnixWare-5*) SHLIB_CFLAGS="-KPIC" SHLIB_LD="cc -G" SHLIB_LD_LIBS="" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="-ldl" # Some UNIX_SV* systems (unixware 1.1.2 for example) have linkers # that don't grok the -Bexport option. Test that it does. AC_CACHE_CHECK([for ld accepts -Bexport flag], tcl_cv_ld_Bexport, [ hold_ldflags=$LDFLAGS LDFLAGS="$LDFLAGS -Wl,-Bexport" AC_TRY_LINK(, [int i;], tcl_cv_ld_Bexport=yes, tcl_cv_ld_Bexport=no) LDFLAGS=$hold_ldflags]) if test $tcl_cv_ld_Bexport = yes; then LDFLAGS="$LDFLAGS -Wl,-Bexport" fi CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; esac if test "$do64bit" = "yes" -a "$do64bit_ok" = "no" ; then AC_MSG_WARN([64bit support being disabled -- don't know magic for this platform]) fi # Step 4: disable dynamic loading if requested via a command-line switch. AC_ARG_ENABLE(load, AC_HELP_STRING([--disable-load], [disallow dynamic loading and "load" command (default: enabled)]), [tcl_ok=$enableval], [tcl_ok=yes]) if test "$tcl_ok" = "no"; then DL_OBJS="" fi if test "x$DL_OBJS" != "x" ; then BUILD_DLTEST="\$(DLTEST_TARGETS)" else echo "Can't figure out how to do dynamic loading or shared libraries" echo "on this system." SHLIB_CFLAGS="" SHLIB_LD="" SHLIB_SUFFIX="" DL_OBJS="tclLoadNone.o" DL_LIBS="" LDFLAGS="$LDFLAGS_ORIG" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" BUILD_DLTEST="" fi LDFLAGS="$LDFLAGS $LDFLAGS_ARCH" # If we're running gcc, then change the C flags for compiling shared # libraries to the right flags for gcc, instead of those for the # standard manufacturer compiler. if test "$DL_OBJS" != "tclLoadNone.o" ; then if test "$GCC" = "yes" ; then case $system in AIX-*) ;; BSD/OS*) ;; IRIX*) ;; NetBSD-*|FreeBSD-*) ;; Darwin-*) ;; SCO_SV-3.2*) ;; windows) ;; *) SHLIB_CFLAGS="-fPIC" ;; esac fi fi if test "$SHARED_LIB_SUFFIX" = "" ; then SHARED_LIB_SUFFIX='${PACKAGE_VERSION}${SHLIB_SUFFIX}' fi if test "$UNSHARED_LIB_SUFFIX" = "" ; then UNSHARED_LIB_SUFFIX='${PACKAGE_VERSION}.a' fi AC_SUBST(DL_LIBS) AC_SUBST(CFLAGS_DEBUG) AC_SUBST(CFLAGS_OPTIMIZE) AC_SUBST(CFLAGS_WARNING) AC_SUBST(STLIB_LD) AC_SUBST(SHLIB_LD) AC_SUBST(SHLIB_LD_LIBS) AC_SUBST(SHLIB_CFLAGS) AC_SUBST(LD_LIBRARY_PATH_VAR) # These must be called after we do the basic CFLAGS checks and # verify any possible 64-bit or similar switches are necessary TEA_TCL_EARLY_FLAGS TEA_TCL_64BIT_FLAGS ]) #-------------------------------------------------------------------- # TEA_SERIAL_PORT # # Determine which interface to use to talk to the serial port. # Note that #include lines must begin in leftmost column for # some compilers to recognize them as preprocessor directives, # and some build environments have stdin not pointing at a # pseudo-terminal (usually /dev/null instead.) # # Arguments: # none # # Results: # # Defines only one of the following vars: # HAVE_SYS_MODEM_H # USE_TERMIOS # USE_TERMIO # USE_SGTTY # #-------------------------------------------------------------------- AC_DEFUN(TEA_SERIAL_PORT, [ AC_CHECK_HEADERS(sys/modem.h) AC_CACHE_CHECK([termios vs. termio vs. sgtty], tcl_cv_api_serial, [ AC_TRY_RUN([ #include int main() { struct termios t; if (tcgetattr(0, &t) == 0) { cfsetospeed(&t, 0); t.c_cflag |= PARENB | PARODD | CSIZE | CSTOPB; return 0; } return 1; }], tcl_cv_api_serial=termios, tcl_cv_api_serial=no, tcl_cv_api_serial=no) if test $tcl_cv_api_serial = no ; then AC_TRY_RUN([ #include int main() { struct termio t; if (ioctl(0, TCGETA, &t) == 0) { t.c_cflag |= CBAUD | PARENB | PARODD | CSIZE | CSTOPB; return 0; } return 1; }], tcl_cv_api_serial=termio, tcl_cv_api_serial=no, tcl_cv_api_serial=no) fi if test $tcl_cv_api_serial = no ; then AC_TRY_RUN([ #include int main() { struct sgttyb t; if (ioctl(0, TIOCGETP, &t) == 0) { t.sg_ospeed = 0; t.sg_flags |= ODDP | EVENP | RAW; return 0; } return 1; }], tcl_cv_api_serial=sgtty, tcl_cv_api_serial=no, tcl_cv_api_serial=no) fi if test $tcl_cv_api_serial = no ; then AC_TRY_RUN([ #include #include int main() { struct termios t; if (tcgetattr(0, &t) == 0 || errno == ENOTTY || errno == ENXIO || errno == EINVAL) { cfsetospeed(&t, 0); t.c_cflag |= PARENB | PARODD | CSIZE | CSTOPB; return 0; } return 1; }], tcl_cv_api_serial=termios, tcl_cv_api_serial=no, tcl_cv_api_serial=no) fi if test $tcl_cv_api_serial = no; then AC_TRY_RUN([ #include #include int main() { struct termio t; if (ioctl(0, TCGETA, &t) == 0 || errno == ENOTTY || errno == ENXIO || errno == EINVAL) { t.c_cflag |= CBAUD | PARENB | PARODD | CSIZE | CSTOPB; return 0; } return 1; }], tcl_cv_api_serial=termio, tcl_cv_api_serial=no, tcl_cv_api_serial=no) fi if test $tcl_cv_api_serial = no; then AC_TRY_RUN([ #include #include int main() { struct sgttyb t; if (ioctl(0, TIOCGETP, &t) == 0 || errno == ENOTTY || errno == ENXIO || errno == EINVAL) { t.sg_ospeed = 0; t.sg_flags |= ODDP | EVENP | RAW; return 0; } return 1; }], tcl_cv_api_serial=sgtty, tcl_cv_api_serial=none, tcl_cv_api_serial=none) fi]) case $tcl_cv_api_serial in termios) AC_DEFINE(USE_TERMIOS, 1, [Use the termios API for serial lines]);; termio) AC_DEFINE(USE_TERMIO, 1, [Use the termio API for serial lines]);; sgtty) AC_DEFINE(USE_SGTTY, 1, [Use the sgtty API for serial lines]);; esac ]) #-------------------------------------------------------------------- # TEA_MISSING_POSIX_HEADERS # # Supply substitutes for missing POSIX header files. Special # notes: # - stdlib.h doesn't define strtol, strtoul, or # strtod insome versions of SunOS # - some versions of string.h don't declare procedures such # as strstr # # Arguments: # none # # Results: # # Defines some of the following vars: # NO_DIRENT_H # NO_ERRNO_H # NO_VALUES_H # HAVE_LIMITS_H or NO_LIMITS_H # NO_STDLIB_H # NO_STRING_H # NO_SYS_WAIT_H # NO_DLFCN_H # HAVE_SYS_PARAM_H # # HAVE_STRING_H ? # # tkUnixPort.h checks for HAVE_LIMITS_H, so do both HAVE and # CHECK on limits.h #-------------------------------------------------------------------- AC_DEFUN(TEA_MISSING_POSIX_HEADERS, [ AC_CACHE_CHECK([dirent.h], tcl_cv_dirent_h, AC_TRY_LINK([#include #include ], [ #ifndef _POSIX_SOURCE # ifdef __Lynx__ /* * Generate compilation error to make the test fail: Lynx headers * are only valid if really in the POSIX environment. */ missing_procedure(); # endif #endif DIR *d; struct dirent *entryPtr; char *p; d = opendir("foobar"); entryPtr = readdir(d); p = entryPtr->d_name; closedir(d); ], tcl_cv_dirent_h=yes, tcl_cv_dirent_h=no)) if test $tcl_cv_dirent_h = no; then AC_DEFINE(NO_DIRENT_H, 1, [Do we have ?]) fi AC_CHECK_HEADER(errno.h, , [AC_DEFINE(NO_ERRNO_H, 1, [Do we have ?])]) AC_CHECK_HEADER(float.h, , [AC_DEFINE(NO_FLOAT_H, 1, [Do we have ?])]) AC_CHECK_HEADER(values.h, , [AC_DEFINE(NO_VALUES_H, 1, [Do we have ?])]) AC_CHECK_HEADER(limits.h, [AC_DEFINE(HAVE_LIMITS_H, 1, [Do we have ?])], [AC_DEFINE(NO_LIMITS_H, 1, [Do we have ?])]) AC_CHECK_HEADER(stdlib.h, tcl_ok=1, tcl_ok=0) AC_EGREP_HEADER(strtol, stdlib.h, , tcl_ok=0) AC_EGREP_HEADER(strtoul, stdlib.h, , tcl_ok=0) AC_EGREP_HEADER(strtod, stdlib.h, , tcl_ok=0) if test $tcl_ok = 0; then AC_DEFINE(NO_STDLIB_H, 1, [Do we have ?]) 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, 1, [Do we have ?]) fi AC_CHECK_HEADER(sys/wait.h, , [AC_DEFINE(NO_SYS_WAIT_H, 1, [Do we have ?])]) AC_CHECK_HEADER(dlfcn.h, , [AC_DEFINE(NO_DLFCN_H, 1, [Do we have ?])]) # OS/390 lacks sys/param.h (and doesn't need it, by chance). AC_HAVE_HEADERS(sys/param.h) ]) #-------------------------------------------------------------------- # TEA_PATH_X # # Locate the X11 header files and the X11 library archive. Try # the ac_path_x macro first, but if it doesn't find the X stuff # (e.g. because there's no xmkmf program) then check through # a list of possible directories. Under some conditions the # autoconf macro will return an include directory that contains # no include files, so double-check its result just to be safe. # # This should be called after TEA_CONFIG_CFLAGS as setting the # LIBS line can confuse some configure macro magic. # # Arguments: # none # # Results: # # Sets the following vars: # XINCLUDES # XLIBSW # PKG_LIBS (appends to) # #-------------------------------------------------------------------- AC_DEFUN(TEA_PATH_X, [ if test "${TEA_WINDOWINGSYSTEM}" = "x11" ; then TEA_PATH_UNIX_X fi ]) AC_DEFUN(TEA_PATH_UNIX_X, [ AC_PATH_X not_really_there="" if test "$no_x" = ""; then if test "$x_includes" = ""; then AC_TRY_CPP([#include ], , not_really_there="yes") else if test ! -r $x_includes/X11/Intrinsic.h; then not_really_there="yes" fi fi fi if test "$no_x" = "yes" -o "$not_really_there" = "yes"; then AC_MSG_CHECKING([for X11 header files]) found_xincludes="no" AC_TRY_CPP([#include ], found_xincludes="yes", found_xincludes="no") if test "$found_xincludes" = "no"; then dirs="/usr/unsupported/include /usr/local/include /usr/X386/include /usr/X11R6/include /usr/X11R5/include /usr/include/X11R5 /usr/include/X11R4 /usr/openwin/include /usr/X11/include /usr/sww/include" for i in $dirs ; do if test -r $i/X11/Intrinsic.h; then AC_MSG_RESULT([$i]) XINCLUDES=" -I$i" found_xincludes="yes" break fi done fi else if test "$x_includes" != ""; then XINCLUDES="-I$x_includes" found_xincludes="yes" fi fi if test found_xincludes = "no"; then AC_MSG_RESULT([couldn't find any!]) fi if test "$no_x" = yes; then AC_MSG_CHECKING([for X11 libraries]) XLIBSW=nope dirs="/usr/unsupported/lib /usr/local/lib /usr/X386/lib /usr/X11R6/lib /usr/X11R5/lib /usr/lib/X11R5 /usr/lib/X11R4 /usr/openwin/lib /usr/X11/lib /usr/sww/X11/lib" for i in $dirs ; do if test -r $i/libX11.a -o -r $i/libX11.so -o -r $i/libX11.sl; then AC_MSG_RESULT([$i]) XLIBSW="-L$i -lX11" x_libraries="$i" break fi done else if test "$x_libraries" = ""; then XLIBSW=-lX11 else XLIBSW="-L$x_libraries -lX11" fi fi if test "$XLIBSW" = nope ; then AC_CHECK_LIB(Xwindow, XCreateWindow, XLIBSW=-lXwindow) fi if test "$XLIBSW" = nope ; then AC_MSG_RESULT([could not find any! Using -lX11.]) XLIBSW=-lX11 fi if test x"${XLIBSW}" != x ; then PKG_LIBS="${PKG_LIBS} ${XLIBSW}" fi ]) #-------------------------------------------------------------------- # TEA_BLOCKING_STYLE # # The statements below check for systems where POSIX-style # non-blocking I/O (O_NONBLOCK) doesn't work or is unimplemented. # On these systems (mostly older ones), use the old BSD-style # FIONBIO approach instead. # # Arguments: # none # # Results: # # Defines some of the following vars: # HAVE_SYS_IOCTL_H # HAVE_SYS_FILIO_H # USE_FIONBIO # O_NONBLOCK # #-------------------------------------------------------------------- AC_DEFUN(TEA_BLOCKING_STYLE, [ AC_CHECK_HEADERS(sys/ioctl.h) AC_CHECK_HEADERS(sys/filio.h) TEA_CONFIG_SYSTEM AC_MSG_CHECKING([FIONBIO vs. O_NONBLOCK for nonblocking I/O]) case $system in # There used to be code here to use FIONBIO under AIX. However, it # was reported that FIONBIO doesn't work under AIX 3.2.5. Since # using O_NONBLOCK seems fine under AIX 4.*, I removed the FIONBIO # code (JO, 5/31/97). OSF*) AC_DEFINE(USE_FIONBIO, 1, [Should we use FIONBIO?]) AC_MSG_RESULT([FIONBIO]) ;; SunOS-4*) AC_DEFINE(USE_FIONBIO, 1, [Should we use FIONBIO?]) AC_MSG_RESULT([FIONBIO]) ;; *) AC_MSG_RESULT([O_NONBLOCK]) ;; esac ]) #-------------------------------------------------------------------- # TEA_TIME_HANLDER # # Checks how the system deals with time.h, what time structures # are used on the system, and what fields the structures have. # # Arguments: # none # # Results: # # Defines some of the following vars: # USE_DELTA_FOR_TZ # HAVE_TM_GMTOFF # HAVE_TM_TZADJ # HAVE_TIMEZONE_VAR # #-------------------------------------------------------------------- AC_DEFUN(TEA_TIME_HANDLER, [ AC_CHECK_HEADERS(sys/time.h) AC_HEADER_TIME AC_STRUCT_TIMEZONE AC_CHECK_FUNCS(gmtime_r localtime_r) AC_CACHE_CHECK([tm_tzadj in struct tm], tcl_cv_member_tm_tzadj, AC_TRY_COMPILE([#include ], [struct tm tm; tm.tm_tzadj;], tcl_cv_member_tm_tzadj=yes, tcl_cv_member_tm_tzadj=no)) if test $tcl_cv_member_tm_tzadj = yes ; then AC_DEFINE(HAVE_TM_TZADJ, 1, [Should we use the tm_tzadj field of struct tm?]) fi AC_CACHE_CHECK([tm_gmtoff in struct tm], tcl_cv_member_tm_gmtoff, AC_TRY_COMPILE([#include ], [struct tm tm; tm.tm_gmtoff;], tcl_cv_member_tm_gmtoff=yes, tcl_cv_member_tm_gmtoff=no)) if test $tcl_cv_member_tm_gmtoff = yes ; then AC_DEFINE(HAVE_TM_GMTOFF, 1, [Should we use the tm_gmtoff field of struct tm?]) fi # # Its important to include time.h in this check, as some systems # (like convex) have timezone functions, etc. # AC_CACHE_CHECK([long timezone variable], tcl_cv_timezone_long, AC_TRY_COMPILE([#include ], [extern long timezone; timezone += 1; exit (0);], tcl_cv_timezone_long=yes, tcl_cv_timezone_long=no)) if test $tcl_cv_timezone_long = yes ; then AC_DEFINE(HAVE_TIMEZONE_VAR, 1, [Should we use the global timezone variable?]) else # # On some systems (eg IRIX 6.2), timezone is a time_t and not a long. # AC_CACHE_CHECK([time_t timezone variable], tcl_cv_timezone_time, AC_TRY_COMPILE([#include ], [extern time_t timezone; timezone += 1; exit (0);], tcl_cv_timezone_time=yes, tcl_cv_timezone_time=no)) if test $tcl_cv_timezone_time = yes ; then AC_DEFINE(HAVE_TIMEZONE_VAR, 1, [Should we use the global timezone variable?]) fi fi ]) #-------------------------------------------------------------------- # TEA_BUGGY_STRTOD # # Under Solaris 2.4, strtod returns the wrong value for the # terminating character under some conditions. Check for this # and if the problem exists use a substitute procedure # "fixstrtod" (provided by Tcl) that corrects the error. # Also, on Compaq's Tru64 Unix 5.0, # strtod(" ") returns 0.0 instead of a failure to convert. # # Arguments: # none # # Results: # # Might defines some of the following vars: # strtod (=fixstrtod) # #-------------------------------------------------------------------- AC_DEFUN(TEA_BUGGY_STRTOD, [ AC_CHECK_FUNC(strtod, tcl_strtod=1, tcl_strtod=0) if test "$tcl_strtod" = 1; then AC_CACHE_CHECK([for Solaris2.4/Tru64 strtod bugs], tcl_cv_strtod_buggy,[ AC_TRY_RUN([ extern double strtod(); int main() { char *infString="Inf", *nanString="NaN", *spaceString=" "; char *term; double value; value = strtod(infString, &term); if ((term != infString) && (term[-1] == 0)) { exit(1); } value = strtod(nanString, &term); if ((term != nanString) && (term[-1] == 0)) { exit(1); } value = strtod(spaceString, &term); if (term == (spaceString+1)) { exit(1); } exit(0); }], tcl_cv_strtod_buggy=ok, tcl_cv_strtod_buggy=buggy, tcl_cv_strtod_buggy=buggy)]) if test "$tcl_cv_strtod_buggy" = buggy; then AC_LIBOBJ([fixstrtod]) USE_COMPAT=1 AC_DEFINE(strtod, fixstrtod, [Do we want to use the strtod() in compat?]) fi fi ]) #-------------------------------------------------------------------- # TEA_TCL_LINK_LIBS # # Search for the libraries needed to link the Tcl shell. # Things like the math library (-lm) and socket stuff (-lsocket vs. # -lnsl) are dealt with here. # # Arguments: # Requires the following vars to be set in the Makefile: # DL_LIBS # LIBS # MATH_LIBS # # Results: # # Subst's the following var: # TCL_LIBS # MATH_LIBS # # Might append to the following vars: # LIBS # # Might define the following vars: # HAVE_NET_ERRNO_H # #-------------------------------------------------------------------- AC_DEFUN(TEA_TCL_LINK_LIBS, [ #-------------------------------------------------------------------- # On a few very rare systems, all of the libm.a stuff is # already in libc.a. Set compiler flags accordingly. # Also, Linux requires the "ieee" library for math to work # right (and it must appear before "-lm"). #-------------------------------------------------------------------- AC_CHECK_FUNC(sin, MATH_LIBS="", MATH_LIBS="-lm") AC_CHECK_LIB(ieee, main, [MATH_LIBS="-lieee $MATH_LIBS"]) #-------------------------------------------------------------------- # Interactive UNIX requires -linet instead of -lsocket, plus it # needs net/errno.h to define the socket-related error codes. #-------------------------------------------------------------------- AC_CHECK_LIB(inet, main, [LIBS="$LIBS -linet"]) AC_CHECK_HEADER(net/errno.h, [ AC_DEFINE(HAVE_NET_ERRNO_H, 1, [Do we have ?])]) #-------------------------------------------------------------------- # Check for the existence of the -lsocket and -lnsl libraries. # The order here is important, so that they end up in the right # order in the command line generated by make. Here are some # special considerations: # 1. Use "connect" and "accept" to check for -lsocket, and # "gethostbyname" to check for -lnsl. # 2. Use each function name only once: can't redo a check because # autoconf caches the results of the last check and won't redo it. # 3. Use -lnsl and -lsocket only if they supply procedures that # aren't already present in the normal libraries. This is because # IRIX 5.2 has libraries, but they aren't needed and they're # bogus: they goof up name resolution if used. # 4. On some SVR4 systems, can't use -lsocket without -lnsl too. # To get around this problem, check for both libraries together # if -lsocket doesn't work by itself. #-------------------------------------------------------------------- tcl_checkBoth=0 AC_CHECK_FUNC(connect, tcl_checkSocket=0, tcl_checkSocket=1) if test "$tcl_checkSocket" = 1; then AC_CHECK_FUNC(setsockopt, , [AC_CHECK_LIB(socket, setsockopt, LIBS="$LIBS -lsocket", tcl_checkBoth=1)]) fi if test "$tcl_checkBoth" = 1; then tk_oldLibs=$LIBS LIBS="$LIBS -lsocket -lnsl" AC_CHECK_FUNC(accept, tcl_checkNsl=0, [LIBS=$tk_oldLibs]) fi AC_CHECK_FUNC(gethostbyname, , [AC_CHECK_LIB(nsl, gethostbyname, [LIBS="$LIBS -lnsl"])]) # Don't perform the eval of the libraries here because DL_LIBS # won't be set until we call TEA_CONFIG_CFLAGS TCL_LIBS='${DL_LIBS} ${LIBS} ${MATH_LIBS}' AC_SUBST(TCL_LIBS) AC_SUBST(MATH_LIBS) ]) #-------------------------------------------------------------------- # TEA_TCL_EARLY_FLAGS # # Check for what flags are needed to be passed so the correct OS # features are available. # # Arguments: # None # # Results: # # Might define the following vars: # _ISOC99_SOURCE # _LARGEFILE64_SOURCE # _LARGEFILE_SOURCE64 # #-------------------------------------------------------------------- AC_DEFUN(TEA_TCL_EARLY_FLAG,[ AC_CACHE_VAL([tcl_cv_flag_]translit($1,[A-Z],[a-z]), AC_TRY_COMPILE([$2], $3, [tcl_cv_flag_]translit($1,[A-Z],[a-z])=no, AC_TRY_COMPILE([[#define ]$1[ 1 ]$2], $3, [tcl_cv_flag_]translit($1,[A-Z],[a-z])=yes, [tcl_cv_flag_]translit($1,[A-Z],[a-z])=no))) if test ["x${tcl_cv_flag_]translit($1,[A-Z],[a-z])[}" = "xyes"] ; then AC_DEFINE($1, 1, [Add the ]$1[ flag when building]) tcl_flags="$tcl_flags $1" fi ]) AC_DEFUN(TEA_TCL_EARLY_FLAGS,[ AC_MSG_CHECKING([for required early compiler flags]) tcl_flags="" TEA_TCL_EARLY_FLAG(_ISOC99_SOURCE,[#include ], [char *p = (char *)strtoll; char *q = (char *)strtoull;]) TEA_TCL_EARLY_FLAG(_LARGEFILE64_SOURCE,[#include ], [struct stat64 buf; int i = stat64("/", &buf);]) TEA_TCL_EARLY_FLAG(_LARGEFILE_SOURCE64,[#include ], [char *p = (char *)open64;]) if test "x${tcl_flags}" = "x" ; then AC_MSG_RESULT([none]) else AC_MSG_RESULT([${tcl_flags}]) fi ]) #-------------------------------------------------------------------- # TEA_TCL_64BIT_FLAGS # # Check for what is defined in the way of 64-bit features. # # Arguments: # None # # Results: # # Might define the following vars: # TCL_WIDE_INT_IS_LONG # TCL_WIDE_INT_TYPE # HAVE_STRUCT_DIRENT64 # HAVE_STRUCT_STAT64 # HAVE_TYPE_OFF64_T # #-------------------------------------------------------------------- AC_DEFUN(TEA_TCL_64BIT_FLAGS, [ AC_MSG_CHECKING([for 64-bit integer type]) AC_CACHE_VAL(tcl_cv_type_64bit,[ tcl_cv_type_64bit=none # See if the compiler knows natively about __int64 AC_TRY_COMPILE(,[__int64 value = (__int64) 0;], tcl_type_64bit=__int64, tcl_type_64bit="long long") # See if we should use long anyway Note that we substitute in the # type that is our current guess for a 64-bit type inside this check # program, so it should be modified only carefully... AC_TRY_COMPILE(,[switch (0) { case 1: case (sizeof(]${tcl_type_64bit}[)==sizeof(long)): ; }],tcl_cv_type_64bit=${tcl_type_64bit})]) if test "${tcl_cv_type_64bit}" = none ; then AC_DEFINE(TCL_WIDE_INT_IS_LONG, 1, [Are wide integers to be implemented with C 'long's?]) AC_MSG_RESULT([using long]) elif test "${tcl_cv_type_64bit}" = "__int64" \ -a "${TEA_PLATFORM}" = "windows" ; then # We actually want to use the default tcl.h checks in this # case to handle both TCL_WIDE_INT_TYPE and TCL_LL_MODIFIER* AC_MSG_RESULT([using Tcl header defaults]) else AC_DEFINE_UNQUOTED(TCL_WIDE_INT_TYPE,${tcl_cv_type_64bit}, [What type should be used to define wide integers?]) AC_MSG_RESULT([${tcl_cv_type_64bit}]) # Now check for auxiliary declarations AC_CACHE_CHECK([for struct dirent64], tcl_cv_struct_dirent64,[ AC_TRY_COMPILE([#include #include ],[struct dirent64 p;], tcl_cv_struct_dirent64=yes,tcl_cv_struct_dirent64=no)]) if test "x${tcl_cv_struct_dirent64}" = "xyes" ; then AC_DEFINE(HAVE_STRUCT_DIRENT64, 1, [Is 'struct dirent64' in ?]) fi AC_CACHE_CHECK([for struct stat64], tcl_cv_struct_stat64,[ AC_TRY_COMPILE([#include ],[struct stat64 p; ], tcl_cv_struct_stat64=yes,tcl_cv_struct_stat64=no)]) if test "x${tcl_cv_struct_stat64}" = "xyes" ; then AC_DEFINE(HAVE_STRUCT_STAT64, 1, [Is 'struct stat64' in ?]) fi AC_CHECK_FUNCS(open64 lseek64) AC_MSG_CHECKING([for off64_t]) AC_CACHE_VAL(tcl_cv_type_off64_t,[ AC_TRY_COMPILE([#include ],[off64_t offset; ], tcl_cv_type_off64_t=yes,tcl_cv_type_off64_t=no)]) dnl Define HAVE_TYPE_OFF64_T only when the off64_t type and the dnl functions lseek64 and open64 are defined. if test "x${tcl_cv_type_off64_t}" = "xyes" && \ test "x${ac_cv_func_lseek64}" = "xyes" && \ test "x${ac_cv_func_open64}" = "xyes" ; then AC_DEFINE(HAVE_TYPE_OFF64_T, 1, [Is off64_t in ?]) AC_MSG_RESULT([yes]) else AC_MSG_RESULT([no]) fi fi ]) ## ## Here ends the standard Tcl configuration bits and starts the ## TEA specific functions ## #------------------------------------------------------------------------ # TEA_INIT -- # # Init various Tcl Extension Architecture (TEA) variables. # This should be the first called TEA_* macro. # # Arguments: # none # # Results: # # Defines and substs the following vars: # CYGPATH # EXEEXT # Defines only: # TEA_VERSION # TEA_INITED # TEA_PLATFORM (windows or unix) # # "cygpath" is used on windows to generate native path names for include # files. These variables should only be used with the compiler and linker # since they generate native path names. # # EXEEXT # Select the executable extension based on the host type. This # is a lightweight replacement for AC_EXEEXT that doesn't require # a compiler. #------------------------------------------------------------------------ AC_DEFUN(TEA_INIT, [ # TEA extensions pass this us the version of TEA they think they # are compatible with. TEA_VERSION="3.5" AC_MSG_CHECKING([for correct TEA configuration]) if test x"${PACKAGE_NAME}" = x ; then AC_MSG_ERROR([ The PACKAGE_NAME variable must be defined by your TEA configure.in]) fi if test x"$1" = x ; then AC_MSG_ERROR([ TEA version not specified.]) elif test "$1" != "${TEA_VERSION}" ; then AC_MSG_RESULT([warning: requested TEA version "$1", have "${TEA_VERSION}"]) else AC_MSG_RESULT([ok (TEA ${TEA_VERSION})]) fi case "`uname -s`" in *win32*|*WIN32*|*CYGWIN_NT*|*CYGWIN_9*|*CYGWIN_ME*|*MINGW32_*) AC_CHECK_PROG(CYGPATH, cygpath, cygpath -w, echo) EXEEXT=".exe" TEA_PLATFORM="windows" ;; *) CYGPATH=echo EXEEXT="" TEA_PLATFORM="unix" ;; esac # Check if exec_prefix is set. If not use fall back to prefix. # Note when adjusted, so that TEA_PREFIX can correct for this. # This is needed for recursive configures, since autoconf propagates # $prefix, but not $exec_prefix (doh!). if test x$exec_prefix = xNONE ; then exec_prefix_default=yes exec_prefix=$prefix fi AC_SUBST(EXEEXT) AC_SUBST(CYGPATH) # This package name must be replaced statically for AC_SUBST to work AC_SUBST(PKG_LIB_FILE) # Substitute STUB_LIB_FILE in case package creates a stub library too. AC_SUBST(PKG_STUB_LIB_FILE) # We AC_SUBST these here to ensure they are subst'ed, # in case the user doesn't call TEA_ADD_... AC_SUBST(PKG_STUB_SOURCES) AC_SUBST(PKG_STUB_OBJECTS) AC_SUBST(PKG_TCL_SOURCES) AC_SUBST(PKG_HEADERS) AC_SUBST(PKG_INCLUDES) AC_SUBST(PKG_LIBS) AC_SUBST(PKG_CFLAGS) ]) #------------------------------------------------------------------------ # TEA_ADD_SOURCES -- # # Specify one or more source files. Users should check for # the right platform before adding to their list. # It is not important to specify the directory, as long as it is # in the generic, win or unix subdirectory of $(srcdir). # # Arguments: # one or more file names # # Results: # # Defines and substs the following vars: # PKG_SOURCES # PKG_OBJECTS #------------------------------------------------------------------------ AC_DEFUN(TEA_ADD_SOURCES, [ vars="$@" for i in $vars; do case $i in [\$]*) # allow $-var names PKG_SOURCES="$PKG_SOURCES $i" PKG_OBJECTS="$PKG_OBJECTS $i" ;; *) # check for existence - allows for generic/win/unix VPATH if test ! -f "${srcdir}/$i" -a ! -f "${srcdir}/generic/$i" \ -a ! -f "${srcdir}/win/$i" -a ! -f "${srcdir}/unix/$i" \ ; then AC_MSG_ERROR([could not find source file '$i']) fi PKG_SOURCES="$PKG_SOURCES $i" # this assumes it is in a VPATH dir i=`basename $i` # handle user calling this before or after TEA_SETUP_COMPILER if test x"${OBJEXT}" != x ; then j="`echo $i | sed -e 's/\.[[^.]]*$//'`.${OBJEXT}" else j="`echo $i | sed -e 's/\.[[^.]]*$//'`.\${OBJEXT}" fi PKG_OBJECTS="$PKG_OBJECTS $j" ;; esac done AC_SUBST(PKG_SOURCES) AC_SUBST(PKG_OBJECTS) ]) #------------------------------------------------------------------------ # TEA_ADD_STUB_SOURCES -- # # Specify one or more source files. Users should check for # the right platform before adding to their list. # It is not important to specify the directory, as long as it is # in the generic, win or unix subdirectory of $(srcdir). # # Arguments: # one or more file names # # Results: # # Defines and substs the following vars: # PKG_STUB_SOURCES # PKG_STUB_OBJECTS #------------------------------------------------------------------------ AC_DEFUN(TEA_ADD_STUB_SOURCES, [ vars="$@" for i in $vars; do # check for existence - allows for generic/win/unix VPATH if test ! -f "${srcdir}/$i" -a ! -f "${srcdir}/generic/$i" \ -a ! -f "${srcdir}/win/$i" -a ! -f "${srcdir}/unix/$i" \ ; then AC_MSG_ERROR([could not find stub source file '$i']) fi PKG_STUB_SOURCES="$PKG_STUB_SOURCES $i" # this assumes it is in a VPATH dir i=`basename $i` # handle user calling this before or after TEA_SETUP_COMPILER if test x"${OBJEXT}" != x ; then j="`echo $i | sed -e 's/\.[[^.]]*$//'`.${OBJEXT}" else j="`echo $i | sed -e 's/\.[[^.]]*$//'`.\${OBJEXT}" fi PKG_STUB_OBJECTS="$PKG_STUB_OBJECTS $j" done AC_SUBST(PKG_STUB_SOURCES) AC_SUBST(PKG_STUB_OBJECTS) ]) #------------------------------------------------------------------------ # TEA_ADD_TCL_SOURCES -- # # Specify one or more Tcl source files. These should be platform # independent runtime files. # # Arguments: # one or more file names # # Results: # # Defines and substs the following vars: # PKG_TCL_SOURCES #------------------------------------------------------------------------ AC_DEFUN(TEA_ADD_TCL_SOURCES, [ vars="$@" for i in $vars; do # check for existence, be strict because it is installed if test ! -f "${srcdir}/$i" ; then AC_MSG_ERROR([could not find tcl source file '${srcdir}/$i']) fi PKG_TCL_SOURCES="$PKG_TCL_SOURCES $i" done AC_SUBST(PKG_TCL_SOURCES) ]) #------------------------------------------------------------------------ # TEA_ADD_HEADERS -- # # Specify one or more source headers. Users should check for # the right platform before adding to their list. # # Arguments: # one or more file names # # Results: # # Defines and substs the following vars: # PKG_HEADERS #------------------------------------------------------------------------ AC_DEFUN(TEA_ADD_HEADERS, [ vars="$@" for i in $vars; do # check for existence, be strict because it is installed if test ! -f "${srcdir}/$i" ; then AC_MSG_ERROR([could not find header file '${srcdir}/$i']) fi PKG_HEADERS="$PKG_HEADERS $i" done AC_SUBST(PKG_HEADERS) ]) #------------------------------------------------------------------------ # TEA_ADD_INCLUDES -- # # Specify one or more include dirs. Users should check for # the right platform before adding to their list. # # Arguments: # one or more file names # # Results: # # Defines and substs the following vars: # PKG_INCLUDES #------------------------------------------------------------------------ AC_DEFUN(TEA_ADD_INCLUDES, [ vars="$@" for i in $vars; do PKG_INCLUDES="$PKG_INCLUDES $i" done AC_SUBST(PKG_INCLUDES) ]) #------------------------------------------------------------------------ # TEA_ADD_LIBS -- # # Specify one or more libraries. Users should check for # the right platform before adding to their list. For Windows, # libraries provided in "foo.lib" format will be converted to # "-lfoo" when using GCC (mingw). # # Arguments: # one or more file names # # Results: # # Defines and substs the following vars: # PKG_LIBS #------------------------------------------------------------------------ AC_DEFUN(TEA_ADD_LIBS, [ vars="$@" for i in $vars; do if test "${TEA_PLATFORM}" = "windows" -a "$GCC" = "yes" ; then # Convert foo.lib to -lfoo for GCC. No-op if not *.lib i=`echo "$i" | sed -e 's/^\([[^-]].*\)\.lib[$]/-l\1/i'` fi PKG_LIBS="$PKG_LIBS $i" done AC_SUBST(PKG_LIBS) ]) #------------------------------------------------------------------------ # TEA_ADD_CFLAGS -- # # Specify one or more CFLAGS. Users should check for # the right platform before adding to their list. # # Arguments: # one or more file names # # Results: # # Defines and substs the following vars: # PKG_CFLAGS #------------------------------------------------------------------------ AC_DEFUN(TEA_ADD_CFLAGS, [ PKG_CFLAGS="$PKG_CFLAGS $@" AC_SUBST(PKG_CFLAGS) ]) #------------------------------------------------------------------------ # TEA_PREFIX -- # # Handle the --prefix=... option by defaulting to what Tcl gave # # Arguments: # none # # Results: # # If --prefix or --exec-prefix was not specified, $prefix and # $exec_prefix will be set to the values given to Tcl when it was # configured. #------------------------------------------------------------------------ AC_DEFUN(TEA_PREFIX, [ if test "${prefix}" = "NONE"; then prefix_default=yes if test x"${TCL_PREFIX}" != x; then AC_MSG_NOTICE([--prefix defaulting to TCL_PREFIX ${TCL_PREFIX}]) prefix=${TCL_PREFIX} else AC_MSG_NOTICE([--prefix defaulting to /usr/local]) prefix=/usr/local fi fi if test "${exec_prefix}" = "NONE" -a x"${prefix_default}" = x"yes" \ -o x"${exec_prefix_default}" = x"yes" ; then if test x"${TCL_EXEC_PREFIX}" != x; then AC_MSG_NOTICE([--exec-prefix defaulting to TCL_EXEC_PREFIX ${TCL_EXEC_PREFIX}]) exec_prefix=${TCL_EXEC_PREFIX} else AC_MSG_NOTICE([--exec-prefix defaulting to ${prefix}]) exec_prefix=$prefix fi fi ]) #------------------------------------------------------------------------ # TEA_SETUP_COMPILER_CC -- # # Do compiler checks the way we want. This is just a replacement # for AC_PROG_CC in TEA configure.in files to make them cleaner. # # Arguments: # none # # Results: # # Sets up CC var and other standard bits we need to make executables. #------------------------------------------------------------------------ AC_DEFUN(TEA_SETUP_COMPILER_CC, [ # Don't put any macros that use the compiler (e.g. AC_TRY_COMPILE) # in this macro, they need to go into TEA_SETUP_COMPILER instead. # If the user did not set CFLAGS, set it now to keep # the AC_PROG_CC macro from adding "-g -O2". if test "${CFLAGS+set}" != "set" ; then CFLAGS="" fi AC_PROG_CC AC_PROG_CPP AC_PROG_INSTALL #-------------------------------------------------------------------- # Checks to see if the make program sets the $MAKE variable. #-------------------------------------------------------------------- AC_PROG_MAKE_SET #-------------------------------------------------------------------- # Find ranlib #-------------------------------------------------------------------- AC_PROG_RANLIB #-------------------------------------------------------------------- # Determines the correct binary file extension (.o, .obj, .exe etc.) #-------------------------------------------------------------------- AC_OBJEXT AC_EXEEXT ]) #------------------------------------------------------------------------ # TEA_SETUP_COMPILER -- # # Do compiler checks that use the compiler. This must go after # TEA_SETUP_COMPILER_CC, which does the actual compiler check. # # Arguments: # none # # Results: # # Sets up CC var and other standard bits we need to make executables. #------------------------------------------------------------------------ AC_DEFUN(TEA_SETUP_COMPILER, [ # Any macros that use the compiler (e.g. AC_TRY_COMPILE) have to go here. AC_REQUIRE([TEA_SETUP_COMPILER_CC]) #------------------------------------------------------------------------ # If we're using GCC, see if the compiler understands -pipe. If so, use it. # It makes compiling go faster. (This is only a performance feature.) #------------------------------------------------------------------------ if test -z "$no_pipe" -a -n "$GCC"; then AC_MSG_CHECKING([if the compiler understands -pipe]) OLDCC="$CC" CC="$CC -pipe" AC_TRY_COMPILE(,, AC_MSG_RESULT([yes]), CC="$OLDCC" AC_MSG_RESULT([no])) fi #-------------------------------------------------------------------- # Common compiler flag setup #-------------------------------------------------------------------- AC_C_BIGENDIAN if test "${TEA_PLATFORM}" = "unix" ; then TEA_TCL_LINK_LIBS TEA_MISSING_POSIX_HEADERS # Let the user call this, because if it triggers, they will # need a compat/strtod.c that is correct. Users can also # use Tcl_GetDouble(FromObj) instead. #TEA_BUGGY_STRTOD fi ]) #------------------------------------------------------------------------ # TEA_MAKE_LIB -- # # Generate a line that can be used to build a shared/unshared library # in a platform independent manner. # # Arguments: # none # # Requires: # # Results: # # Defines the following vars: # CFLAGS - Done late here to note disturb other AC macros # MAKE_LIB - Command to execute to build the Tcl library; # differs depending on whether or not Tcl is being # compiled as a shared library. # MAKE_SHARED_LIB Makefile rule for building a shared library # MAKE_STATIC_LIB Makefile rule for building a static library # MAKE_STUB_LIB Makefile rule for building a stub library #------------------------------------------------------------------------ AC_DEFUN(TEA_MAKE_LIB, [ if test "${TEA_PLATFORM}" = "windows" -a "$GCC" != "yes"; then MAKE_STATIC_LIB="\${STLIB_LD} -out:\[$]@ \$(PKG_OBJECTS)" MAKE_SHARED_LIB="\${SHLIB_LD} \${SHLIB_LD_LIBS} \${LDFLAGS_DEFAULT} -out:\[$]@ \$(PKG_OBJECTS)" MAKE_STUB_LIB="\${STLIB_LD} -out:\[$]@ \$(PKG_STUB_OBJECTS)" else MAKE_STATIC_LIB="\${STLIB_LD} \[$]@ \$(PKG_OBJECTS)" MAKE_SHARED_LIB="\${SHLIB_LD} -o \[$]@ \$(PKG_OBJECTS) \${SHLIB_LD_LIBS}" MAKE_STUB_LIB="\${STLIB_LD} \[$]@ \$(PKG_STUB_OBJECTS)" fi if test "${SHARED_BUILD}" = "1" ; then MAKE_LIB="${MAKE_SHARED_LIB} " else MAKE_LIB="${MAKE_STATIC_LIB} " fi #-------------------------------------------------------------------- # Shared libraries and static libraries have different names. # Use the double eval to make sure any variables in the suffix is # substituted. (@@@ Might not be necessary anymore) #-------------------------------------------------------------------- if test "${TEA_PLATFORM}" = "windows" ; then if test "${SHARED_BUILD}" = "1" ; then # We force the unresolved linking of symbols that are really in # the private libraries of Tcl and Tk. SHLIB_LD_LIBS="${SHLIB_LD_LIBS} \"`${CYGPATH} ${TCL_BIN_DIR}/${TCL_STUB_LIB_FILE}`\"" if test x"${TK_BIN_DIR}" != x ; then SHLIB_LD_LIBS="${SHLIB_LD_LIBS} \"`${CYGPATH} ${TK_BIN_DIR}/${TK_STUB_LIB_FILE}`\"" fi eval eval "PKG_LIB_FILE=${PACKAGE_NAME}${SHARED_LIB_SUFFIX}" else eval eval "PKG_LIB_FILE=${PACKAGE_NAME}${UNSHARED_LIB_SUFFIX}" fi # Some packages build their own stubs libraries eval eval "PKG_STUB_LIB_FILE=${PACKAGE_NAME}stub${UNSHARED_LIB_SUFFIX}" # These aren't needed on Windows (either MSVC or gcc) RANLIB=: RANLIB_STUB=: else RANLIB_STUB="${RANLIB}" if test "${SHARED_BUILD}" = "1" ; then SHLIB_LD_LIBS="${SHLIB_LD_LIBS} ${TCL_STUB_LIB_SPEC}" if test x"${TK_BIN_DIR}" != x ; then SHLIB_LD_LIBS="${SHLIB_LD_LIBS} ${TK_STUB_LIB_SPEC}" fi eval eval "PKG_LIB_FILE=lib${PACKAGE_NAME}${SHARED_LIB_SUFFIX}" RANLIB=: else eval eval "PKG_LIB_FILE=lib${PACKAGE_NAME}${UNSHARED_LIB_SUFFIX}" fi # Some packages build their own stubs libraries eval eval "PKG_STUB_LIB_FILE=lib${PACKAGE_NAME}stub${UNSHARED_LIB_SUFFIX}" fi # These are escaped so that only CFLAGS is picked up at configure time. # The other values will be substituted at make time. CFLAGS="${CFLAGS} \${CFLAGS_DEFAULT} \${CFLAGS_WARNING}" if test "${SHARED_BUILD}" = "1" ; then CFLAGS="${CFLAGS} \${SHLIB_CFLAGS}" fi AC_SUBST(MAKE_LIB) AC_SUBST(MAKE_SHARED_LIB) AC_SUBST(MAKE_STATIC_LIB) AC_SUBST(MAKE_STUB_LIB) AC_SUBST(RANLIB_STUB) ]) #------------------------------------------------------------------------ # TEA_LIB_SPEC -- # # Compute the name of an existing object library located in libdir # from the given base name and produce the appropriate linker flags. # # Arguments: # basename The base name of the library without version # numbers, extensions, or "lib" prefixes. # extra_dir Extra directory in which to search for the # library. This location is used first, then # $prefix/$exec-prefix, then some defaults. # # Requires: # TEA_INIT and TEA_PREFIX must be called first. # # Results: # # Defines the following vars: # ${basename}_LIB_NAME The computed library name. # ${basename}_LIB_SPEC The computed linker flags. #------------------------------------------------------------------------ AC_DEFUN(TEA_LIB_SPEC, [ AC_MSG_CHECKING([for $1 library]) # Look in exec-prefix for the library (defined by TEA_PREFIX). tea_lib_name_dir="${exec_prefix}/lib" # Or in a user-specified location. if test x"$2" != x ; then tea_extra_lib_dir=$2 else tea_extra_lib_dir=NONE fi for i in \ `ls -dr ${tea_extra_lib_dir}/$1[[0-9]]*.lib 2>/dev/null ` \ `ls -dr ${tea_extra_lib_dir}/lib$1[[0-9]]* 2>/dev/null ` \ `ls -dr ${tea_lib_name_dir}/$1[[0-9]]*.lib 2>/dev/null ` \ `ls -dr ${tea_lib_name_dir}/lib$1[[0-9]]* 2>/dev/null ` \ `ls -dr /usr/lib/$1[[0-9]]*.lib 2>/dev/null ` \ `ls -dr /usr/lib/lib$1[[0-9]]* 2>/dev/null ` \ `ls -dr /usr/local/lib/$1[[0-9]]*.lib 2>/dev/null ` \ `ls -dr /usr/local/lib/lib$1[[0-9]]* 2>/dev/null ` ; do if test -f "$i" ; then tea_lib_name_dir=`dirname $i` $1_LIB_NAME=`basename $i` $1_LIB_PATH_NAME=$i break fi done if test "${TEA_PLATFORM}" = "windows"; then $1_LIB_SPEC=\"`${CYGPATH} ${$1_LIB_PATH_NAME} 2>/dev/null`\" else # Strip off the leading "lib" and trailing ".a" or ".so" tea_lib_name_lib=`echo ${$1_LIB_NAME}|sed -e 's/^lib//' -e 's/\.[[^.]]*$//' -e 's/\.so.*//'` $1_LIB_SPEC="-L${tea_lib_name_dir} -l${tea_lib_name_lib}" fi if test "x${$1_LIB_NAME}" = x ; then AC_MSG_ERROR([not found]) else AC_MSG_RESULT([${$1_LIB_SPEC}]) fi ]) #------------------------------------------------------------------------ # TEA_PRIVATE_TCL_HEADERS -- # # Locate the private Tcl include files # # Arguments: # # Requires: # TCL_SRC_DIR Assumes that TEA_LOAD_TCLCONFIG has # already been called. # # Results: # # Substs the following vars: # TCL_TOP_DIR_NATIVE # TCL_GENERIC_DIR_NATIVE # TCL_UNIX_DIR_NATIVE # TCL_WIN_DIR_NATIVE # TCL_BMAP_DIR_NATIVE # TCL_TOOL_DIR_NATIVE # TCL_PLATFORM_DIR_NATIVE # TCL_BIN_DIR_NATIVE # TCL_INCLUDES #------------------------------------------------------------------------ AC_DEFUN(TEA_PRIVATE_TCL_HEADERS, [ AC_MSG_CHECKING([for Tcl private include files]) TCL_SRC_DIR_NATIVE=`${CYGPATH} ${TCL_SRC_DIR}` TCL_TOP_DIR_NATIVE=\"${TCL_SRC_DIR_NATIVE}\" TCL_GENERIC_DIR_NATIVE=\"${TCL_SRC_DIR_NATIVE}/generic\" TCL_UNIX_DIR_NATIVE=\"${TCL_SRC_DIR_NATIVE}/unix\" TCL_WIN_DIR_NATIVE=\"${TCL_SRC_DIR_NATIVE}/win\" TCL_BMAP_DIR_NATIVE=\"${TCL_SRC_DIR_NATIVE}/bitmaps\" TCL_TOOL_DIR_NATIVE=\"${TCL_SRC_DIR_NATIVE}/tools\" TCL_COMPAT_DIR_NATIVE=\"${TCL_SRC_DIR_NATIVE}/compat\" if test "${TEA_PLATFORM}" = "windows"; then TCL_PLATFORM_DIR_NATIVE=${TCL_WIN_DIR_NATIVE} else TCL_PLATFORM_DIR_NATIVE=${TCL_UNIX_DIR_NATIVE} fi # We want to ensure these are substituted so as not to require # any *_NATIVE vars be defined in the Makefile TCL_INCLUDES="-I${TCL_GENERIC_DIR_NATIVE} -I${TCL_PLATFORM_DIR_NATIVE}" if test "`uname -s`" = "Darwin"; then # If Tcl was built as a framework, attempt to use # the framework's Headers and PrivateHeaders directories case ${TCL_DEFS} in *TCL_FRAMEWORK*) if test -d "${TCL_BIN_DIR}/Headers" -a -d "${TCL_BIN_DIR}/PrivateHeaders"; then TCL_INCLUDES="-I\"${TCL_BIN_DIR}/Headers\" -I\"${TCL_BIN_DIR}/PrivateHeaders\" ${TCL_INCLUDES}"; else TCL_INCLUDES="${TCL_INCLUDES} ${TCL_INCLUDE_SPEC} `echo "${TCL_INCLUDE_SPEC}" | sed -e 's/Headers/PrivateHeaders/'`"; fi ;; esac fi AC_SUBST(TCL_TOP_DIR_NATIVE) AC_SUBST(TCL_GENERIC_DIR_NATIVE) AC_SUBST(TCL_UNIX_DIR_NATIVE) AC_SUBST(TCL_WIN_DIR_NATIVE) AC_SUBST(TCL_BMAP_DIR_NATIVE) AC_SUBST(TCL_TOOL_DIR_NATIVE) AC_SUBST(TCL_PLATFORM_DIR_NATIVE) AC_SUBST(TCL_INCLUDES) AC_MSG_RESULT([Using srcdir found in tclConfig.sh: ${TCL_SRC_DIR}]) ]) #------------------------------------------------------------------------ # TEA_PUBLIC_TCL_HEADERS -- # # Locate the installed public Tcl header files # # Arguments: # None. # # Requires: # CYGPATH must be set # # Results: # # Adds a --with-tclinclude switch to configure. # Result is cached. # # Substs the following vars: # TCL_INCLUDES #------------------------------------------------------------------------ AC_DEFUN(TEA_PUBLIC_TCL_HEADERS, [ AC_MSG_CHECKING([for Tcl public headers]) AC_ARG_WITH(tclinclude, [ --with-tclinclude directory containing the public Tcl header files], with_tclinclude=${withval}) AC_CACHE_VAL(ac_cv_c_tclh, [ # Use the value from --with-tclinclude, if it was given if test x"${with_tclinclude}" != x ; then if test -f "${with_tclinclude}/tcl.h" ; then ac_cv_c_tclh=${with_tclinclude} else AC_MSG_ERROR([${with_tclinclude} directory does not contain tcl.h]) fi else if test "`uname -s`" = "Darwin"; then # If Tcl was built as a framework, attempt to use # the framework's Headers directory case ${TCL_DEFS} in *TCL_FRAMEWORK*) list="`ls -d ${TCL_BIN_DIR}/Headers 2>/dev/null`" ;; esac fi # Look in the source dir only if Tcl is not installed, # and in that situation, look there before installed locations. if test -f "${TCL_BIN_DIR}/Makefile" ; then list="$list `ls -d ${TCL_SRC_DIR}/generic 2>/dev/null`" fi # Check order: pkg --prefix location, Tcl's --prefix location, # relative to directory of tclConfig.sh. eval "temp_includedir=${includedir}" list="$list \ `ls -d ${temp_includedir} 2>/dev/null` \ `ls -d ${TCL_PREFIX}/include 2>/dev/null` \ `ls -d ${TCL_BIN_DIR}/../include 2>/dev/null`" if test "${TEA_PLATFORM}" != "windows" -o "$GCC" = "yes"; then list="$list /usr/local/include /usr/include" if test x"${TCL_INCLUDE_SPEC}" != x ; then d=`echo "${TCL_INCLUDE_SPEC}" | sed -e 's/^-I//'` list="$list `ls -d ${d} 2>/dev/null`" fi fi for i in $list ; do if test -f "$i/tcl.h" ; then ac_cv_c_tclh=$i break fi done fi ]) # Print a message based on how we determined the include path if test x"${ac_cv_c_tclh}" = x ; then AC_MSG_ERROR([tcl.h not found. Please specify its location with --with-tclinclude]) else AC_MSG_RESULT([${ac_cv_c_tclh}]) fi # Convert to a native path and substitute into the output files. INCLUDE_DIR_NATIVE=`${CYGPATH} ${ac_cv_c_tclh}` TCL_INCLUDES=-I\"${INCLUDE_DIR_NATIVE}\" AC_SUBST(TCL_INCLUDES) ]) #------------------------------------------------------------------------ # TEA_PRIVATE_TK_HEADERS -- # # Locate the private Tk include files # # Arguments: # # Requires: # TK_SRC_DIR Assumes that TEA_LOAD_TKCONFIG has # already been called. # # Results: # # Substs the following vars: # TK_INCLUDES #------------------------------------------------------------------------ AC_DEFUN(TEA_PRIVATE_TK_HEADERS, [ AC_MSG_CHECKING([for Tk private include files]) TK_SRC_DIR_NATIVE=`${CYGPATH} ${TK_SRC_DIR}` TK_TOP_DIR_NATIVE=\"${TK_SRC_DIR_NATIVE}\" TK_UNIX_DIR_NATIVE=\"${TK_SRC_DIR_NATIVE}/unix\" TK_WIN_DIR_NATIVE=\"${TK_SRC_DIR_NATIVE}/win\" TK_GENERIC_DIR_NATIVE=\"${TK_SRC_DIR_NATIVE}/generic\" TK_XLIB_DIR_NATIVE=\"${TK_SRC_DIR_NATIVE}/xlib\" if test "${TEA_PLATFORM}" = "windows"; then TK_PLATFORM_DIR_NATIVE=${TK_WIN_DIR_NATIVE} else TK_PLATFORM_DIR_NATIVE=${TK_UNIX_DIR_NATIVE} fi # We want to ensure these are substituted so as not to require # any *_NATIVE vars be defined in the Makefile TK_INCLUDES="-I${TK_GENERIC_DIR_NATIVE} -I${TK_PLATFORM_DIR_NATIVE}" if test "${TEA_WINDOWINGSYSTEM}" = "win32" \ -o "${TEA_WINDOWINGSYSTEM}" = "aqua"; then TK_INCLUDES="${TK_INCLUDES} -I${TK_XLIB_DIR_NATIVE}" fi if test "${TEA_WINDOWINGSYSTEM}" = "aqua"; then TK_INCLUDES="${TK_INCLUDES} -I${TK_SRC_DIR_NATIVE}/macosx" fi if test "`uname -s`" = "Darwin"; then # If Tk was built as a framework, attempt to use # the framework's Headers and PrivateHeaders directories case ${TK_DEFS} in *TK_FRAMEWORK*) if test -d "${TK_BIN_DIR}/Headers" -a -d "${TK_BIN_DIR}/PrivateHeaders"; then TK_INCLUDES="-I\"${TK_BIN_DIR}/Headers\" -I\"${TK_BIN_DIR}/PrivateHeaders\" ${TK_INCLUDES}"; fi ;; esac fi AC_SUBST(TK_TOP_DIR_NATIVE) AC_SUBST(TK_UNIX_DIR_NATIVE) AC_SUBST(TK_WIN_DIR_NATIVE) AC_SUBST(TK_GENERIC_DIR_NATIVE) AC_SUBST(TK_XLIB_DIR_NATIVE) AC_SUBST(TK_PLATFORM_DIR_NATIVE) AC_SUBST(TK_INCLUDES) AC_MSG_RESULT([Using srcdir found in tkConfig.sh: ${TK_SRC_DIR}]) ]) #------------------------------------------------------------------------ # TEA_PUBLIC_TK_HEADERS -- # # Locate the installed public Tk header files # # Arguments: # None. # # Requires: # CYGPATH must be set # # Results: # # Adds a --with-tkinclude switch to configure. # Result is cached. # # Substs the following vars: # TK_INCLUDES #------------------------------------------------------------------------ AC_DEFUN(TEA_PUBLIC_TK_HEADERS, [ AC_MSG_CHECKING([for Tk public headers]) AC_ARG_WITH(tkinclude, [ --with-tkinclude directory containing the public Tk header files.], with_tkinclude=${withval}) AC_CACHE_VAL(ac_cv_c_tkh, [ # Use the value from --with-tkinclude, if it was given if test x"${with_tkinclude}" != x ; then if test -f "${with_tkinclude}/tk.h" ; then ac_cv_c_tkh=${with_tkinclude} else AC_MSG_ERROR([${with_tkinclude} directory does not contain tk.h]) fi else if test "`uname -s`" = "Darwin"; then # If Tk was built as a framework, attempt to use # the framework's Headers directory. case ${TK_DEFS} in *TK_FRAMEWORK*) list="`ls -d ${TK_BIN_DIR}/Headers 2>/dev/null`" ;; esac fi # Look in the source dir only if Tk is not installed, # and in that situation, look there before installed locations. if test -f "${TK_BIN_DIR}/Makefile" ; then list="$list `ls -d ${TK_SRC_DIR}/generic 2>/dev/null`" fi # Check order: pkg --prefix location, Tk's --prefix location, # relative to directory of tkConfig.sh, Tcl's --prefix location, # relative to directory of tclConfig.sh. eval "temp_includedir=${includedir}" list="$list \ `ls -d ${temp_includedir} 2>/dev/null` \ `ls -d ${TK_PREFIX}/include 2>/dev/null` \ `ls -d ${TK_BIN_DIR}/../include 2>/dev/null` \ `ls -d ${TCL_PREFIX}/include 2>/dev/null` \ `ls -d ${TCL_BIN_DIR}/../include 2>/dev/null`" if test "${TEA_PLATFORM}" != "windows" -o "$GCC" = "yes"; then list="$list /usr/local/include /usr/include" fi for i in $list ; do if test -f "$i/tk.h" ; then ac_cv_c_tkh=$i break fi done fi ]) # Print a message based on how we determined the include path if test x"${ac_cv_c_tkh}" = x ; then AC_MSG_ERROR([tk.h not found. Please specify its location with --with-tkinclude]) else AC_MSG_RESULT([${ac_cv_c_tkh}]) fi # Convert to a native path and substitute into the output files. INCLUDE_DIR_NATIVE=`${CYGPATH} ${ac_cv_c_tkh}` TK_INCLUDES=-I\"${INCLUDE_DIR_NATIVE}\" AC_SUBST(TK_INCLUDES) if test "${TEA_WINDOWINGSYSTEM}" = "win32" \ -o "${TEA_WINDOWINGSYSTEM}" = "aqua"; then # On Windows and Aqua, we need the X compat headers AC_MSG_CHECKING([for X11 header files]) if test ! -r "${INCLUDE_DIR_NATIVE}/X11/Xlib.h"; then INCLUDE_DIR_NATIVE="`${CYGPATH} ${TK_SRC_DIR}/xlib`" TK_XINCLUDES=-I\"${INCLUDE_DIR_NATIVE}\" AC_SUBST(TK_XINCLUDES) fi AC_MSG_RESULT([${INCLUDE_DIR_NATIVE}]) fi ]) #------------------------------------------------------------------------ # TEA_PROG_TCLSH # Determine the fully qualified path name of the tclsh executable # in the Tcl build directory or the tclsh installed in a bin # directory. This macro will correctly determine the name # of the tclsh executable even if tclsh has not yet been # built in the build directory. The tclsh found is always # associated with a tclConfig.sh file. This tclsh should be used # only for running extension test cases. It should never be # or generation of files (like pkgIndex.tcl) at build time. # # Arguments # none # # Results # Subst's the following values: # TCLSH_PROG #------------------------------------------------------------------------ AC_DEFUN(TEA_PROG_TCLSH, [ AC_MSG_CHECKING([for tclsh]) if test -f "${TCL_BIN_DIR}/Makefile" ; then # tclConfig.sh is in Tcl build directory if test "${TEA_PLATFORM}" = "windows"; then TCLSH_PROG="${TCL_BIN_DIR}/tclsh${TCL_MAJOR_VERSION}${TCL_MINOR_VERSION}${TCL_DBGX}${EXEEXT}" else TCLSH_PROG="${TCL_BIN_DIR}/tclsh" fi else # tclConfig.sh is in install location if test "${TEA_PLATFORM}" = "windows"; then TCLSH_PROG="tclsh${TCL_MAJOR_VERSION}${TCL_MINOR_VERSION}${TCL_DBGX}${EXEEXT}" else TCLSH_PROG="tclsh${TCL_MAJOR_VERSION}.${TCL_MINOR_VERSION}${TCL_DBGX}" fi list="`ls -d ${TCL_BIN_DIR}/../bin 2>/dev/null` \ `ls -d ${TCL_BIN_DIR}/.. 2>/dev/null` \ `ls -d ${TCL_PREFIX}/bin 2>/dev/null`" for i in $list ; do if test -f "$i/${TCLSH_PROG}" ; then REAL_TCL_BIN_DIR="`cd "$i"; pwd`" break fi done TCLSH_PROG="${REAL_TCL_BIN_DIR}/${TCLSH_PROG}" fi AC_MSG_RESULT([${TCLSH_PROG}]) AC_SUBST(TCLSH_PROG) ]) #------------------------------------------------------------------------ # TEA_PROG_WISH # Determine the fully qualified path name of the wish executable # in the Tk build directory or the wish installed in a bin # directory. This macro will correctly determine the name # of the wish executable even if wish has not yet been # built in the build directory. The wish found is always # associated with a tkConfig.sh file. This wish should be used # only for running extension test cases. It should never be # or generation of files (like pkgIndex.tcl) at build time. # # Arguments # none # # Results # Subst's the following values: # WISH_PROG #------------------------------------------------------------------------ AC_DEFUN(TEA_PROG_WISH, [ AC_MSG_CHECKING([for wish]) if test -f "${TK_BIN_DIR}/Makefile" ; then # tkConfig.sh is in Tk build directory if test "${TEA_PLATFORM}" = "windows"; then WISH_PROG="${TK_BIN_DIR}/wish${TK_MAJOR_VERSION}${TK_MINOR_VERSION}${TK_DBGX}${EXEEXT}" else WISH_PROG="${TK_BIN_DIR}/wish" fi else # tkConfig.sh is in install location if test "${TEA_PLATFORM}" = "windows"; then WISH_PROG="wish${TK_MAJOR_VERSION}${TK_MINOR_VERSION}${TK_DBGX}${EXEEXT}" else WISH_PROG="wish${TK_MAJOR_VERSION}.${TK_MINOR_VERSION}${TK_DBGX}" fi list="`ls -d ${TK_BIN_DIR}/../bin 2>/dev/null` \ `ls -d ${TK_BIN_DIR}/.. 2>/dev/null` \ `ls -d ${TK_PREFIX}/bin 2>/dev/null`" for i in $list ; do if test -f "$i/${WISH_PROG}" ; then REAL_TK_BIN_DIR="`cd "$i"; pwd`" break fi done WISH_PROG="${REAL_TK_BIN_DIR}/${WISH_PROG}" fi AC_MSG_RESULT([${WISH_PROG}]) AC_SUBST(WISH_PROG) ]) #------------------------------------------------------------------------ # TEA_PATH_CONFIG -- # # Locate the ${1}Config.sh file and perform a sanity check on # the ${1} compile flags. These are used by packages like # [incr Tk] that load *Config.sh files from more than Tcl and Tk. # # Arguments: # none # # Results: # # Adds the following arguments to configure: # --with-$1=... # # Defines the following vars: # $1_BIN_DIR Full path to the directory containing # the $1Config.sh file #------------------------------------------------------------------------ AC_DEFUN(TEA_PATH_CONFIG, [ # # Ok, lets find the $1 configuration # First, look for one uninstalled. # the alternative search directory is invoked by --with-$1 # if test x"${no_$1}" = x ; then # we reset no_$1 in case something fails here no_$1=true AC_ARG_WITH($1, [ --with-$1 directory containing $1 configuration ($1Config.sh)], with_$1config=${withval}) AC_MSG_CHECKING([for $1 configuration]) AC_CACHE_VAL(ac_cv_c_$1config,[ # First check to see if --with-$1 was specified. if test x"${with_$1config}" != x ; then case ${with_$1config} in */$1Config.sh ) if test -f ${with_$1config}; then AC_MSG_WARN([--with-$1 argument should refer to directory containing $1Config.sh, not to $1Config.sh itself]) with_$1config=`echo ${with_$1config} | sed 's!/$1Config\.sh$!!'` fi;; esac if test -f "${with_$1config}/$1Config.sh" ; then ac_cv_c_$1config=`(cd ${with_$1config}; pwd)` else AC_MSG_ERROR([${with_$1config} directory doesn't contain $1Config.sh]) fi fi # then check for a private $1 installation if test x"${ac_cv_c_$1config}" = x ; then for i in \ ../$1 \ `ls -dr ../$1*[[0-9]].[[0-9]]*.[[0-9]]* 2>/dev/null` \ `ls -dr ../$1*[[0-9]].[[0-9]][[0-9]] 2>/dev/null` \ `ls -dr ../$1*[[0-9]].[[0-9]] 2>/dev/null` \ `ls -dr ../$1*[[0-9]].[[0-9]]* 2>/dev/null` \ ../../$1 \ `ls -dr ../../$1*[[0-9]].[[0-9]]*.[[0-9]]* 2>/dev/null` \ `ls -dr ../../$1*[[0-9]].[[0-9]][[0-9]] 2>/dev/null` \ `ls -dr ../../$1*[[0-9]].[[0-9]] 2>/dev/null` \ `ls -dr ../../$1*[[0-9]].[[0-9]]* 2>/dev/null` \ ../../../$1 \ `ls -dr ../../../$1*[[0-9]].[[0-9]]*.[[0-9]]* 2>/dev/null` \ `ls -dr ../../../$1*[[0-9]].[[0-9]][[0-9]] 2>/dev/null` \ `ls -dr ../../../$1*[[0-9]].[[0-9]] 2>/dev/null` \ `ls -dr ../../../$1*[[0-9]].[[0-9]]* 2>/dev/null` \ ${srcdir}/../$1 \ `ls -dr ${srcdir}/../$1*[[0-9]].[[0-9]]*.[[0-9]]* 2>/dev/null` \ `ls -dr ${srcdir}/../$1*[[0-9]].[[0-9]][[0-9]] 2>/dev/null` \ `ls -dr ${srcdir}/../$1*[[0-9]].[[0-9]] 2>/dev/null` \ `ls -dr ${srcdir}/../$1*[[0-9]].[[0-9]]* 2>/dev/null` \ ; do if test -f "$i/$1Config.sh" ; then ac_cv_c_$1config=`(cd $i; pwd)` break fi if test -f "$i/unix/$1Config.sh" ; then ac_cv_c_$1config=`(cd $i/unix; pwd)` break fi done fi # check in a few common install locations if test x"${ac_cv_c_$1config}" = x ; then for i in `ls -d ${libdir} 2>/dev/null` \ `ls -d ${exec_prefix}/lib 2>/dev/null` \ `ls -d ${prefix}/lib 2>/dev/null` \ `ls -d /usr/local/lib 2>/dev/null` \ `ls -d /usr/contrib/lib 2>/dev/null` \ `ls -d /usr/lib 2>/dev/null` \ ; do if test -f "$i/$1Config.sh" ; then ac_cv_c_$1config=`(cd $i; pwd)` break fi done fi ]) if test x"${ac_cv_c_$1config}" = x ; then $1_BIN_DIR="# no $1 configs found" AC_MSG_WARN([Cannot find $1 configuration definitions]) exit 0 else no_$1= $1_BIN_DIR=${ac_cv_c_$1config} AC_MSG_RESULT([found $$1_BIN_DIR/$1Config.sh]) fi fi ]) #------------------------------------------------------------------------ # TEA_LOAD_CONFIG -- # # Load the $1Config.sh file # # Arguments: # # Requires the following vars to be set: # $1_BIN_DIR # # Results: # # Subst the following vars: # $1_SRC_DIR # $1_LIB_FILE # $1_LIB_SPEC # #------------------------------------------------------------------------ AC_DEFUN(TEA_LOAD_CONFIG, [ AC_MSG_CHECKING([for existence of ${$1_BIN_DIR}/$1Config.sh]) if test -f "${$1_BIN_DIR}/$1Config.sh" ; then AC_MSG_RESULT([loading]) . ${$1_BIN_DIR}/$1Config.sh else AC_MSG_RESULT([file not found]) fi # # If the $1_BIN_DIR is the build directory (not the install directory), # then set the common variable name to the value of the build variables. # For example, the variable $1_LIB_SPEC will be set to the value # of $1_BUILD_LIB_SPEC. An extension should make use of $1_LIB_SPEC # instead of $1_BUILD_LIB_SPEC since it will work with both an # installed and uninstalled version of Tcl. # if test -f ${$1_BIN_DIR}/Makefile ; then AC_MSG_WARN([Found Makefile - using build library specs for $1]) $1_LIB_SPEC=${$1_BUILD_LIB_SPEC} $1_STUB_LIB_SPEC=${$1_BUILD_STUB_LIB_SPEC} $1_STUB_LIB_PATH=${$1_BUILD_STUB_LIB_PATH} fi AC_SUBST($1_VERSION) AC_SUBST($1_BIN_DIR) AC_SUBST($1_SRC_DIR) AC_SUBST($1_LIB_FILE) AC_SUBST($1_LIB_SPEC) AC_SUBST($1_STUB_LIB_FILE) AC_SUBST($1_STUB_LIB_SPEC) AC_SUBST($1_STUB_LIB_PATH) ]) #------------------------------------------------------------------------ # TEA_PATH_CELIB -- # # Locate Keuchel's celib emulation layer for targeting Win/CE # # Arguments: # none # # Results: # # Adds the following arguments to configure: # --with-celib=... # # Defines the following vars: # CELIB_DIR Full path to the directory containing # the include and platform lib files #------------------------------------------------------------------------ AC_DEFUN(TEA_PATH_CELIB, [ # First, look for one uninstalled. # the alternative search directory is invoked by --with-celib if test x"${no_celib}" = x ; then # we reset no_celib in case something fails here no_celib=true AC_ARG_WITH(celib,[ --with-celib=DIR use Windows/CE support library from DIR], with_celibconfig=${withval}) AC_MSG_CHECKING([for Windows/CE celib directory]) AC_CACHE_VAL(ac_cv_c_celibconfig,[ # First check to see if --with-celibconfig was specified. if test x"${with_celibconfig}" != x ; then if test -d "${with_celibconfig}/inc" ; then ac_cv_c_celibconfig=`(cd ${with_celibconfig}; pwd)` else AC_MSG_ERROR([${with_celibconfig} directory doesn't contain inc directory]) fi fi # then check for a celib library if test x"${ac_cv_c_celibconfig}" = x ; then for i in \ ../celib-palm-3.0 \ ../celib \ ../../celib-palm-3.0 \ ../../celib \ `ls -dr ../celib-*3.[[0-9]]* 2>/dev/null` \ ${srcdir}/../celib-palm-3.0 \ ${srcdir}/../celib \ `ls -dr ${srcdir}/../celib-*3.[[0-9]]* 2>/dev/null` \ ; do if test -d "$i/inc" ; then ac_cv_c_celibconfig=`(cd $i; pwd)` break fi done fi ]) if test x"${ac_cv_c_celibconfig}" = x ; then AC_MSG_ERROR([Cannot find celib support library directory]) else no_celib= CELIB_DIR=${ac_cv_c_celibconfig} CELIB_DIR=`echo "$CELIB_DIR" | sed -e 's!\\\!/!g'` AC_MSG_RESULT([found $CELIB_DIR]) fi fi ]) # Local Variables: # mode: autoconf # End: # BASED ON TEA 1.89 2006/01/25 21:25:02 tclx8.4-8.4.1.orig/tclconfig/install-sh0000755000000000000000000000421212046525461014535 0ustar #!/bin/sh # # install - install a program, script, or datafile # This comes from X11R5; it is not part of GNU. # # $XConsortium: install.sh,v 1.2 89/12/18 14:47:22 jim Exp $ # # This script is compatible with the BSD install script, but was written # from scratch. # # set DOITPROG to echo to test this script # Don't use :- since 4.3BSD and earlier shells don't like it. doit="${DOITPROG-}" # put in absolute paths if you don't have them in your path; or use env. vars. mvprog="${MVPROG-mv}" cpprog="${CPPROG-cp}" chmodprog="${CHMODPROG-chmod}" chownprog="${CHOWNPROG-chown}" chgrpprog="${CHGRPPROG-chgrp}" stripprog="${STRIPPROG-strip}" rmprog="${RMPROG-rm}" instcmd="$mvprog" chmodcmd="" chowncmd="" chgrpcmd="" stripcmd="" rmcmd="$rmprog -f" mvcmd="$mvprog" src="" dst="" while [ x"$1" != x ]; do case $1 in -c) instcmd="$cpprog" shift continue;; -m) chmodcmd="$chmodprog $2" shift shift continue;; -o) chowncmd="$chownprog $2" shift shift continue;; -g) chgrpcmd="$chgrpprog $2" shift shift continue;; -s) stripcmd="$stripprog" shift continue;; *) if [ x"$src" = x ] then src=$1 else dst=$1 fi shift continue;; esac done if [ x"$src" = x ] then echo "install: no input file specified" exit 1 fi if [ x"$dst" = x ] then echo "install: no destination specified" exit 1 fi # If destination is a directory, append the input filename; if your system # does not like double slashes in filenames, you may need to add some logic if [ -d $dst ] then dst="$dst"/`basename $src` fi # Make a temp file name in the proper directory. dstdir=`dirname $dst` dsttmp=$dstdir/#inst.$$# # Move or copy the file name to the temp name $doit $instcmd $src $dsttmp # and set any options; do chmod last to preserve setuid bits if [ x"$chowncmd" != x ]; then $doit $chowncmd $dsttmp; fi if [ x"$chgrpcmd" != x ]; then $doit $chgrpcmd $dsttmp; fi if [ x"$stripcmd" != x ]; then $doit $stripcmd $dsttmp; fi if [ x"$chmodcmd" != x ]; then $doit $chmodcmd $dsttmp; fi # Now rename the file to the real destination. $doit $rmcmd $dst $doit $mvcmd $dsttmp $dst exit 0 tclx8.4-8.4.1.orig/ChangeLog0000644000000000000000000004706612046316204012342 0ustar 2012-11-07 Andreas Kupries **** TCLX 8.4.1 RELEASE **** 2008-12-15 Andreas Kupries * generic/tclExtdInt.h: Handle TIP#336 addition of API to access * generic/tclXgeneral.c: interp->errorLine. * generic/tclXlib.c: 2008-06-30 Pat Thoyts * win/makefile.vc: Updated the NMAKE build files to the * win/rules.vc: current standard set for extensions. * win/nmakehlp.c: * win/common.vc: removed * win/tclx.rc: Added new version resource. 2007-02-27 Jeff Hobbs * unix/tclXunixPort.h: h_errno is a macro on AIX 2006-01-25 Jeff Hobbs * configure.in, configure, tclconfig/tcl.m4: update to TEA 3.5 2005-12-02 Jeff Hobbs * tclconfig/tcl.m4, configure: update to TEA 3.4 * configure.in: remove 'rename' check (no longer used) 2005-11-25 Jeff Hobbs * library/pushd.tcl (pushd): correct dirs arg [Bug 1156134] and clean up some other code. 2005-11-21 Jeff Hobbs **** TCLX 8.4.0 RELEASE **** * generic/tclXstring.c (TclX_CrangeObjCmd): 64-bit cast fix * generic/tclXmath.c (TclX_MathInit): restrict to only add min/max expr funcs in <= 8.4 * generic/tclXkeylist.c: 64-bit cast warning squash * library/tclx.tcl: protect scope of variables in init 2005-11-20 Jeff Hobbs * Makefile.in: correct dist target * README: updated readme and install notes to TclX 8.4 std. * unix/INSTALL: Windows nmake makefile still needs fixing, but * unix/INSTALL.generic (removed): TEA-based system works across * win/INSTALL.txt, win/makefile.vc: the board. * win/common.bc, win/makefile.bc, win/makefile.vc.sub (removed): 2005-11-17 Jeff Hobbs * library/tclx.tcl: unused sample pure Tcl readdir * tests/cmdtrace.test (cmdtrace-3.2): remove errorInfo, as that varies between Tcl versions, but main error is correct. * tests/keylist.test: * generic/tclXkeylist.c (DeleteKeyedListEntry): keep hash entries in sync even if the deleted item was not in the hash. * generic/tclXlist.c (TclX_LemptyObjCmd): simplify to force list conversion, but ignore errors on bad lists. * tests/fmath.test (fmath-1.21): adjust for bignum math in 8.5 2005-10-07 Jeff Hobbs * unix/tclXunixPort.h: Correct INADDR_NONE define. [Bug 1242825] * configure, configure.in, tclconfig/tcl.m4: updated to 3.3, support for Solaris 5.10 and amd64 64-bit builds. 2005-07-27 Jeff Hobbs * generic/tclXselect.c: use unsigned int on Windows for fd type, as that is what Windows expects. Not strictly correct, but select usage on Windows is iffy anyways. 2005-07-12 Jeff Hobbs * generic/tclExtdInt.h (TclXOSGetSelectFnum): use int for fd * unix/tclXunixOS.c (TclXOSGetSelectFnum): (reverses change from * win/tclXwinOS.c (TclXOSGetSelectFnum): 2005-04-26) as TclX * generic/tclXselect.c: uses -1 in handles to indicate unused fd for select. 2005-07-07 Jeff Hobbs * unix/tclXunixOS.c (TclXOSWalkDir): undef readdir as Tcl 8.4 did ifdef'ery that was unnecessary and screwed up threaded builds. 2005-04-26 Jeff Hobbs * generic/tclXbsearch.c (ReadAndCompare): Fix Tcl_Tell return casts * generic/tclXdup.c (DupFileChannel): as it take Tcl_WideInt, * generic/tclXfilescan.c (ScanFile): but off_t is long on Win. * generic/tclXselect.c (ParseSelectFileList): * generic/tclExtdInt.h (TclXOSGetSelectFnum): take unsigned int * unix/tclXunixOS.c (TclXOSGetSelectFnum): for fd * win/tclXwinOS.c (TclXOSGetSelectFnum): (TclXOSftruncate): fix cast from Tcl_Tell 2005-03-28 Jeff Hobbs * configure, configure.in: * Makefile.in (PKG_OBJECTS): add @LIBOBJS@ to needed objects. 2005-03-25 Jeff Hobbs * configure, configure.in: AC_PROG_LN_S no longer needed * tests/help.test: correct help tests to use correct help dir * Makefile.in: doc target cleanup (das) Add helpclean target and make help not rebuild always. Add TCLX_HELP_DIR to TCLSH_ENV. * license.terms (new): minimal license terms file * library/buildhelp.tcl (buildhelp): redir 2>/dev/null for exec col check. (das) * unix/tclXunixPort.h: undef panic for __APPLE__ (das) 2005-03-24 Jeff Hobbs * Makefile.in, tclconfig/tcl.m4: Get AIX wide int type right. * configure, configure.in: Use 'tclx' PACKAGE_NAME, but load 'Tclx'. 2005-03-23 Jeff Hobbs * Makefile.in, tclconfig/tcl.m4: Update to TEA 3.2, refactoring * configure, configure.in: some #defines. Still needs to have header usage on AIX checked, where 'kill' in tclXsignal is crashing the test suite. * pkgIndex.tcl.in, tclconfig/ChangeLog (removed): * generic/tclXinit.c: use TEA3 define names (PACKAGE_*) * generic/tclXselect.c: remove NO_SYS_SELECT_H, rely on HAVE_SYS_SELECT_H from tcl's tclUnixPort.h * win/tclXwinPort.h: remove NO_SYS_SELECT_H define * unix/tclXunixPort.h: remove NO_FLOOR_PROTO_ check * generic/tclXkeylist.c (DeleteKeyedListEntry): fix hash consistency checks when missing cached entry. * generic/tclXlib.c: remove trailing , in enum typdef 2005-03-18 Jeff Hobbs * Makefile.in (AR): use @AR@ 2005-03-16 Jeff Hobbs * generic/tclXmath.c: add ability to handle wide values in min/max math functions and commands. Merged TclX_MinFunc and TclX_MaxFunc into TclX_MinMaxFunc. 2005-02-07 Andreas Kupries * generic/tclXkeylist.c (FindKeyedListEntry): Moved a C99 specific variable declaration to the top of its block, making it C89 compatible. 2005-02-03 Jeff Hobbs * tests/keylist.test, generic/tclXkeylist.c: improve efficiency of keyed lists by layering a hash table over the existing linear list. This has significant performance improvements for larger lists. To avoid use of the hash table, add -DNO_KEYLIST_HASH_TABLE to your CFLAGS. * tests/profile.test: update to pass 8.4 bcc changes * generic/tclXsignal.c (FormatSignalListEntry): dup string passed to TclX_KeyedListSet to ensure we don't break const-ness. * configure, tclconfig/tcl.m4: increase Linux default opt level to -O2. 2005-01-21 Andreas Kupries * unix/tclXunixOS.c: Converted both implementations of TclXOSsleep * win/tclXwinOS.c: from direct access to native time functions to the use of Tcl's more abstract interface (Tcl_Sleep). For the reason behind _this_ change see TIP #233. Our change here now causes TclX to be automatically in sync with any virtualization set up in the core. 2005-01-18 Jeff Hobbs * generic/tclXfcntl.c: make attrNames static 2004-12-21 Jeff Hobbs * tests/cmdtrace.test: updated for minor whitespace changes in Tcl 8.4 results. Will fail on 8.3, but that's not a concern. 2004-12-02 Jeff Hobbs * Makefile.in: cygpath a few required buildhelp vars * configure, configure.in: refactor --with-help check to add 'col' prog check and defer them until TclX help is requested. * library/buildhelp.tcl (buildhelp): convert system call to exec to allow it to work on Windows 2004-12-01 Jeff Hobbs * unix/tools/tclmanpages: note resource.n last appears and lset.n first appears in 8.4 docs. 2004-11-23 Jeff Hobbs * generic/tclXfilescan.c (TclX_ScanfileObjCmd): watch for scanfile closing the open channel. [Bug 1045190] (hellstroem) * configure.in, configure: add check for NO_UNION_WAIT for Solaris, HP and related systems 2004-11-22 Jeff Hobbs * library/tclx.tcl: Reintroduce the addition of the 'help' command * library/help.tcl: as tclx::help* (they can be namespace imported). * configure: Adjust the configure to allow --with-help, which * configure.in: is required to build the TclX help files. This * Makefile.in: still needs work on how users would build and install the help depending on whether it was a CVS or general source distribution. * library/edprocs.tcl (edprocs): harden tmpfile security access * Makefile.in: remove TCL_DEFS dependency * configure.in: add TEA_TIME_HANDLER checks to no longer rely on TCL_DEFS (not good for 8.5). * generic/tclXprofile.c (ProfStrCommandEval): CONST84-ify it * unix/tclXunixSock.c (BindFileHandles): remove impotent channel code on channel2. * doc/TclX.n: minor typo fixes * generic/tclExtdInt.h: compat defines to support building against Tcl 8.5a2+. [Bug 1066799] (dgp) 2004-07-14 Jeff Hobbs * generic/tclXselect.c: undef panic on __APPLE__ (steffen) 2004-06-04 Andreas Kupries * generic/tclExtdInt.h: Changed when 'tclInt.h' is included. Have to be done before 'tcl*Port.h', to prevent a clash over 'TclpPanic'. Don Porter claims that this is ok in general as well. A comment in the file seems to contradict this, but the compilation I tried was ok. If this becomes truly a problem then we may have to refactor the TclX headers to ensure that both Tcl and TclX dependencies are resolved correctly. 2004-05-24 Jeff Hobbs * generic/tclXsocket.c (InfoGetHost): read host after arg count check. [Bug 930035] (teterin) * doc/TclX.n: doc and comment fixes * unix/tclXunixOS.c: * win/tclXwinOS.c: 2004-02-12 Jeff Hobbs * win/tclXwinOS.c (TclXOSkill): close process handle 2003-04-04 Andreas Kupries * configure.in: * tclconfig/tcl.m4: Updated to newest tcl.m4, regenerated configure's. 2002-12-17 Jeff Hobbs * generic/tclXkeylist.c (ValidateKey): move isPath check outside of for loop. (DupKeyedListInternalRep): duplicate value object instead of directly incrementing refcount of existing object to stop memleak. (TclX_KeyedListGetKeys): simplify list result obj creation. (TclX_KeylkeysObjCmd): use obj-ified var set/get routines. * Makefile.in: add valgrind and valgrindtest targets * unix/INSTALL: remove references to Tk-required build 2002-11-12 Karl Lehenbauer * Makefile.in: Put some variables back in that were previously found in Config.mk. "make buildhelp" now works again. * configure: * configure.in: Moved the help dir to the top directory of the TclX source code. It was using a subdir that no longer exists. * unix/tools/bldmanhelp.tcl: Add "package require Tclx" and source the help tools. * unix/tools/instcopy.tcl: Add "package require Tclx" and source the TclX build utilities. * unix/tools/runbuildhelp.tcl: "driver" to run buildhelp since we don't have a Tcl command line that can take the command on the command line. 2002-11-03 Karl Lehenbauer * generic/tclXfilescan.c: Applied patch to fileparse to use the public Tcl_RegExp interface instead of the private TclRegexp. Submitted by Reinhard Max (rmax) [Patch #631096] 2002-10-15 Jeff Hobbs * tclconfig/tcl.m4: * configure: * configure.in: move the CFLAGS definition into TEA_ENABLE_SHARED and make it pick up the env CFLAGS at configure time. 2002-10-15 Andreas Kupries * configure.in: Changed to propagate an initial CFLAGS value to the final definition. A TEA condition (SHARED_BUILD == 1) squashed it, causing it the build system to loose the +DAportable we specify for the AS PA-RISC2.2 build host. This is a problem for _all_ TEA and TEA 2 based configure files. 2002-09-25 Jeff Hobbs * generic/tclExtdInt.h: added TclX_(Struct)Offet header * generic/tclXutil.c: added TclX_StructOffset to handle the changes in the size of Tcl_HashTable when embedded in a structure. * generic/tclExtend.h: added support for 8.4 CONSTification (TIP 27) * generic/tclXbsearch.c: * generic/tclXcmdloop.c: * generic/tclXdebug.c: * generic/tclXdup.c: * generic/tclXfilecmds.c: * generic/tclXlib.c: * generic/tclXprofile.c: * generic/tclXsignal.c: * generic/tclXstring.c: * tests/profile.test: support changed error msgs between 8.3 and 8.4 * tests/string.test: * tests/tcllib.test: 2002-04-11 Jeff Hobbs * configure: * tcl.m4: Enabled COFF as well as CV style debug info with --enable-symbols to allow Dr. Watson users to see function info. More info on debugging levels can be obtained at: http://msdn.microsoft.com/library/en-us/dnvc60/html/gendepdebug.asp 2002-04-03 Jeff Hobbs * generic/tclXgeneral.c (TclX_EchoObjCmd): use encoding aware functions in 8.1+. [Bug #514053] * generic/tclXselect.c: allow to compile on Windows as well (although select isn't supported). * Makefile.in: correct install targets * configure: * configure.in: * tclconfig/tcl.m4: update to latest TEA base files * win/tclXwinCmds.c: use the generic select command definition * win/tclXwinOS.c (TclXNotAvailableError): use Tcl_AppendResult * win/tclXwinPort.h: prevent redefinition complaints * tests/chmod.test: * tests/chroot.test: * tests/fcntl.test: * tests/fstat.test: * tests/ftrunc.test: * tests/lgets.test: * tests/msgcat.test: * tests/nice.test: * tests/pipe.test: * tests/process.test: * tests/profile.test: * tests/tcllib.test: * tests/testlib.tcl: * tests/tryeval.test: * tests/unixcmds.test: convert to use tcltest test command 2002-04-02 Jeff Hobbs * doc/TclX.n: updated to note lack of shell stuff in 8.4. * configure: * configure.in: added FULL_VERSION info * generic/tclExtdInt.h: removed TclX_WriteStr, TclX_Eval and TclX_VarEval as they simply shadowed Tcl commands. Removed TclX_ShellExit (no longer needed). Updated files with Tcl equivs. * generic/tclExtend.h: * generic/tclXcmdloop.c: * generic/tclXdebug.c: * generic/tclXgeneral.c: * generic/tclXinit.c: * generic/tclXlib.c: * generic/tclXtest.c: * generic/tclXutil.c: * generic/tclXinitDSA.c (removed): * generic/tclXinitSA.c (removed): old Tcl plus patch files * tests/cmdtrace.test: * tests/dup.test: * tests/flock.test: * tests/help.test: * tests/process.test: * tests/signal.test: * tests/testlib.tcl: updated tests to use $::tcltest::tcltest instead of relying on TCL_PROGRAM. * Makefile.in: remove tclXinitLib.c * configure: regened * configure.in: call SC_TCL_LINK_LIBS and add MATH_LIBS on unix. * tclconfig/tcl.m4: updated with TEA sample 2002-04-01 Jeff Hobbs * README: added some notes * Makefile.in (new): * aclocal.m4 (new): * configure (new): * configure.in (new): * pkgIndex.tcl.in (new): * tclconfig/ChangeLog (new): * tclconfig/README.txt (new): * tclconfig/install-sh (new): * tclconfig/tcl.m4 (new): updated to new TEA architecture * library/tclx.tcl: changed to force loading of most tclx runtime library files directly * library/arrayprocs.tcl: * library/autoload.tcl: * library/fmath.tcl: minor code cleanup * generic/tclExtend.h: removed all TkX references * generic/tclXcmdInit.c (removed): streamlined into tclXinit.c * generic/tclXinit.c: cleaned up TclX initialization * generic/tclXlibInit.c (removed): streamlined info tclXinit.c * generic/tclXshell.c (removed): shell functionality removed from 8.4+. * unix/Common.mk.in (removed): * unix/Makefile.in (removed): * unix/Makefile.in.sub (removed): * unix/aclocal.m4 (removed): * unix/configure (removed): * unix/configure.in (removed): * unix/pkgIndex.tcl.in (removed): * unix/tcl.m4 (removed): * win/Makefile.in (removed): * win/aclocal.m4 (removed): * win/configure.in (removed): old cygwin make files removed * generic/hello.tcl (removed): no longer used * tests/shell.test (removed): the shell functionality of TclX is being removed in 8.4+ * tests/ucbtests.tcl (removed): old file * tests/*: revamp of test files to use tcltest 'test' command. 2001-10-24 Jeff Hobbs **** POTENTIAL INCOMPATABILITY **** * MASSIVE restructuring underway. Reorganizing into a simple TclX only extension - no more tkx or shell builds. You can retrieve the latest of the old style TclX from the tclx-8-3-0-branch. **** POTENTIAL INCOMPATABILITY **** 2001-09-11 Andreas Kupries * tcl/generic/tclXlib.c (MakeAbsFile): Replaced a call to the internal 'TclpGetCwd' with an access to the public API 'Tcl_GetCwd'. [457266]. Reported by Vincent Darley. 2001-08-01 Jeff Hobbs * doc/TclX.n: * tcl/generic/tclXoscmds.c: allowed sleep to accept double values, to match the Expect sleep command. This prevents conflicts that depended on the order of package requires. [Patch #444332] 2001-05-24 Andreas Kupries * unix/tools/tclmanpages: Added "re_syntax.n" to the list of processed manpages [#405956]. 2001-05-19 Andreas Kupries * All of the changes below are there to fix bug [418295]. * tcl/generic/tclXoscmds.c (TclX_OsCmdsInit): "system" and "sleep" now use the new command creation procedure. * tcl/generic/tclXprocess.c (TclX_ProcessInit): "fork" and "wait" now use the new command creation procedure. * tcl/generic/tclXutil.c (TclX_CreateObjCommand): Added the implementation of this new procedure. * tcl/generic/tclExtdInt.h: Added TclX_CreateObjCommand to encapsulate the logic for the creation of commands FOO and tclx_FOO. 2001-05-15 Andreas Kupries * tcl/generic/tclXlist.c (TclX_LassignObjCmd): Added TCL_LEAVE_ERR_MSG to call of 'Tcl_SetVar2Ex'. This fixes the bug [227478]. 2001-05-07 Andreas Kupries * tcl/generic/tclXgeneral.c (TclX_LoopObjCmd): Changed 'Tcl_AppendStringsToObj' into 'Tcl_AddErrorInfo'. Fixes bug [226388]. Associated patch is [403050]. No need to extend the testsuite, it already contained a test exercising the bug. 2000-08-01 Brent Welch * tcl/unix/Makefile.in: * tk/unix/Makefile.in: Fixed bogus "test -f" on the new HELP_DIR directory, which should be "test -d". 2000-07-30 Brent Welch * win/Makefile.in - fixed because of new definition of TCL_SRC_DIR and TK_SRC_DIR 2000-07-12 Brent Welch * Changed the HELP_DIR to be configurable so I could have parallel builds not all trying to create the same help files. 2000-07-12 Brent Welch * tcl/win/configure.in, common.bc, common.vc Fixed version number to 8.3 * {tcl,tk}/unix/Makefile.in, tweaks to get references to LIB_RUNTIME_DIR properly expanded on irix builds. Also added BUILDHELP macro that is conditional on nroff being present so we don't try to build help files on systems with out nroff. 2000-07-10 Brent Welch * tcl/win/tclXAppInit.c, tk/generic/tkXshell.c, tk/win/tkXAppInit.c - turn off USE_TCL_STUBS * win/Makefile.in, win/configure.in: Cleanup use of stubs library. 2000-04-03 Lee Bernhard * tcl/win/tclXwinOS.c (TclXOSkill): Added support for "kill" command on Windows platforms. 1999-08-20 Scott Stanton * win/aclocal.m4: Updated from latest tcl.m4. * win/Makefile.in: Various changes to support Windows builds. Fixed to properly generate pkgIndex.tcl for tkx. Added Makefile/configure rules.