diff options
| author | Joseph Hunkeler <jhunkeler@gmail.com> | 2015-07-08 20:46:52 -0400 |
|---|---|---|
| committer | Joseph Hunkeler <jhunkeler@gmail.com> | 2015-07-08 20:46:52 -0400 |
| commit | fa080de7afc95aa1c19a6e6fc0e0708ced2eadc4 (patch) | |
| tree | bdda434976bc09c864f2e4fa6f16ba1952b1e555 /vendor/x11iraf/obm/Tcl | |
| download | iraf-linux-fa080de7afc95aa1c19a6e6fc0e0708ced2eadc4.tar.gz | |
Initial commit
Diffstat (limited to 'vendor/x11iraf/obm/Tcl')
213 files changed, 54506 insertions, 0 deletions
diff --git a/vendor/x11iraf/obm/Tcl/Imakefile b/vendor/x11iraf/obm/Tcl/Imakefile new file mode 100644 index 00000000..dca178ec --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/Imakefile @@ -0,0 +1,224 @@ +XCOMM Imakefile for maintaining Tcl in the Object Manager library. +XCOMM 05-Sep-93, Doug Tody NOAO/IRAF. +XCOMM 28-Aug-96, Mike Fitzpatrick NOAO/IRAF. (Revised) + +X11IRAFDIR = ../../ +#include <../../X11IRAF.tmpl> + +XCOMM ------------------ BEGIN TCL DEFINITIONS ---------------------- + + TCL_LIBRARY = /usr/local/lib/tcl + SRC_DIR = . + + +#if defined(MacIIArchitecture) +XCOMM - The following are for Macintosh A/UX + GCC_FLAGS = -w -Wunused -traditional + AC_FLAGS = -DHAVE_UNISTD_H=1 -DNO_STDLIB_H=1 -DNO_STRING_H=1 \ + -DNEED_MATHERR=1 + COMPAT_OBJS = strerror.o strtoul.o tclMtherr.o +#else + +#if defined(PpcDarwinArchitecture) || defined (TenonServer) +XCOMM - The following are for OS X on a PowerPC +#if ((OSMajorVersion == 10) && (OSMinorVersion < 4)) + CPP_FLAGS = -traditional-cpp +#else + CPP_FLAGS = +#endif + GCC_FLAGS = -DNOSTDHDRS -DSYSV -DANSI -D_BSD_SOURCE -W \ + $(CPP_FLAGS) -fstrength-reduce -fpcc-struct-return + AC_FLAGS = $(CPP_FLAGS) -DHAVE_UNISTD_H=1 + CFLAGS += $(CPP_FLAGS) -I. $(AC_FLAGS) $(GCC_FLAGS) + COMPAT_OBJS = +#else + +#if defined(SunArchitecture) && (OSMajorVersion <= 4) +XCOMM - The following are for SunOS + GCC_FLAGS = + AC_FLAGS = -DHAVE_UNISTD_H=1 -DNO_FLOAT_H=1 -DNO_STDLIB_H=1 \ + -DNO_STRING_H=1 -DNEED_MATHERR=1 + COMPAT_OBJS = strerror.o strtoul.o tclMtherr.o +#else + +#if defined(SunArchitecture) && !defined (i386Architecture) +XCOMM - The following are for SunSoft/Solaris +# Hack to compile under SunPRO V4 on Solaris + CCOPTIONS = -Xs + EXTRA_LDOPTIONS = -xildoff + GCC_FLAGS = + AC_FLAGS = -DNO_GETWD=1 -DNO_WAIT3=1 -DHAVE_UNISTD_H=1 \ + -DNO_UNION_WAIT=1 -DNEED_MATHERR=1 -DUSE_STDARG + COMPAT_OBJS = tclMtherr.o +#else + +#if defined(SunArchitecture) && defined (i386Architecture) +XCOMM - The following are for Solaris x86 + CCOPTIONS = + EXTRA_LDOPTIONS = + GCC_FLAGS = + AC_FLAGS = -DNO_GETWD=1 -DNO_WAIT3=1 -DHAVE_UNISTD_H=1 \ + -DNO_UNION_WAIT=1 -DNEED_MATHERR=1 + COMPAT_OBJS = tclMtherr.o +#else + +#if defined(FreeBSDArchitecture) +XCOMM - The following are for FreeBSD + GCC_FLAGS = -DNOSTDHDRS -DSYSV -DANSI -D_BSD_SOURCE -W \ + -fstrength-reduce -fpcc-struct-return + AC_FLAGS = -DHAVE_UNISTD_H=1 + CFLAGS += -I. $(AC_FLAGS) $(GCC_FLAGS) + COMPAT_OBJS = +#else + +#if defined(LinuxArchitecture) +XCOMM - The following are for Linux + GCC_FLAGS = -DNOSTDHDRS -DSYSV -DANSI -D_BSD_SOURCE -W \ + -fstrength-reduce -fpcc-struct-return + AC_FLAGS = -DHAVE_UNISTD_H=1 + COMPAT_OBJS = +#else + +#if defined(HPArchitecture) +XCOMM - The following are for HP-UX + GCC_FLAGS = + AC_FLAGS = -DNO_GETWD=1 -DNO_WAIT3=1 -DHAVE_UNISTD_H=1 \ + -DNO_UNION_WAIT=1 -DNEED_MATHERR=1 + COMPAT_OBJS = tclMtherr.o +#else + +#if defined(OSF1Architecture) +XCOMM - The following are for OSF/1 on Alpha + GCC_FLAGS = + AC_FLAGS = -DHAVE_UNISTD_H=1 -DNO_UNION_WAIT=1 -DNEED_MATHERR=1 + COMPAT_OBJS = tclMtherr.o + +#else + +#if defined(RsArchitecture) +XCOMM - The following are for AIX on Rs/6000 + GCC_FLAGS = + AC_FLAGS = -DHAVE_UNISTD_H=1 -DNO_UNION_WAIT=1 -DNEED_MATHERR=1 + COMPAT_OBJS = tclMtherr.o + +#else +#if defined(cygwinArchitecture) + + GCC_FLAGS = -DUSE_STDARG + AC_FLAGS = -DHAVE_UNISTD_H=1 -DNO_UNION_WAIT=1 -DNO_STDLIB_H=1 + COMPAT_OBJS = +#else + + GCC_FLAGS = + AC_FLAGS = + COMPAT_OBJS = +#endif +#endif +#endif +#endif +#endif +#endif +#endif +#endif +#endif +#endif +#endif + + +# Platform flags. +#if ((GccMajorVersion == 3) && (GccMinorVersion >= 1)) + PL_FLAGS = -DUSE_STDARG +#else +#if ((GccMajorVersion == 4)) + PL_FLAGS = -DUSE_STDARG + CPP_FLAGS = -traditional-cpp +#else + PL_FLAGS = +#endif +#endif + + + DEPENDFLAGS = -I.. -I${SRC_DIR} ${AC_FLAGS} ${PL_FLAGS} + CCOPTIONS = -I.. -I${SRC_DIR} ${AC_FLAGS} ${PL_FLAGS} ${GCC_FLAGS} \ + -DTCL_LIBRARY=\"${TCL_LIBRARY}\" + +UNIX_OBJS = \ + panic.o tclEnv.o tclGlob.o tclMain.o tclUnixAZ.o \ + tclUnixStr.o tclUnixUtil.o + +GENERIC_OBJS = \ + regexp.o tclAsync.o tclBasic.o tclCkalloc.o \ + tclCmdAH.o tclCmdIL.o tclCmdMZ.o tclExpr.o tclGet.o \ + tclHash.o tclHistory.o tclLink.o tclParse.o tclProc.o \ + tclUtil.o tclVar.o + +TCL_OBJS = ${GENERIC_OBJS} ${UNIX_OBJS} ${COMPAT_OBJS} + +XCOMM -------------------- END TCL DEFINITIONS ---------------------- + + +HEADERS = patchlevel.h tclRegexp.h tcl.h tclInt.h tclUnix.h + +SRCS = panic.c regexp.c tclAppInit.c tclAsync.c tclBasic.c \ + tclCkalloc.c tclCmdAH.c tclCmdIL.c tclCmdMZ.c tclEnv.c \ + tclExpr.c tclGet.c tclGlob.c tclHash.c tclHistory.c \ + tclLink.c tclMain.c tclMtherr.c tclParse.c tclProc.c \ + tclTest.c tclUnixAZ.c tclUnixStr.c tclUnixUtil.c tclUtil.c \ + tclVar.c + +OBJS = ${TCL_OBJS} + +SubdirLibraryRule($(OBJS)) + +XCOMM ------------------ BEGIN TCL DEFINITIONS ---------------------- +getcwd.o: $(SRC_DIR)/compat/getcwd.c + $(CC) -c $(CCOPTIONS) $(SRC_DIR)/compat/getcwd.c + +opendir.o: $(SRC_DIR)/compat/opendir.c + $(CC) -c $(CCOPTIONS) $(SRC_DIR)/compat/opendir.c + +strerror.o: $(SRC_DIR)/compat/strerror.c + $(CC) -c $(CCOPTIONS) $(SRC_DIR)/compat/strerror.c + +strstr.o: $(SRC_DIR)/compat/strstr.c + $(CC) -c $(CCOPTIONS) $(SRC_DIR)/compat/strstr.c + +strtod.o: $(SRC_DIR)/compat/strtod.c + $(CC) -c $(CCOPTIONS) $(SRC_DIR)/compat/strtod.c + +strtol.o: $(SRC_DIR)/compat/strtol.c + $(CC) -c $(CCOPTIONS) $(SRC_DIR)/compat/strtol.c + +strtoul.o: $(SRC_DIR)/compat/strtoul.c + $(CC) -c $(CCOPTIONS) $(SRC_DIR)/compat/strtoul.c + +tmpnam.o: $(SRC_DIR)/compat/tmpnam.c + $(CC) -c $(CCOPTIONS) $(SRC_DIR)/compat/tmpnam.c + +waitpid.o: $(SRC_DIR)/compat/waitpid.c + $(CC) -c $(CCOPTIONS) $(SRC_DIR)/compat/waitpid.c +XCOMM -------------------- END TCL DEFINITIONS ---------------------- + + +NormalLintTarget($(SRCS)) +LintLibraryTarget(ar,$(SRCS)) + +includes:: + MakeDir(X11irafIncDir/Tcl) + @(set -x; for i in $(HEADERS); do \ + $(RM) X11irafIncDir/Tcl/$$i; \ + $(CP) -p ObmDir/Tcl/$$i X11irafIncDir/Tcl/$$i; \ + done) + +#if InstallIncludes +install:: + @(set -x; for i in $(HEADERS); do \ + $(RM) X11irafIncDir/Tcl/$$i; \ + done) + for i in $(HEADERS); do \ + (set -x; $(CP) -p $$i X11irafIncDir/Tcl/); \ + done +#endif + +DependTarget() + diff --git a/vendor/x11iraf/obm/Tcl/Imakefile.ORIG b/vendor/x11iraf/obm/Tcl/Imakefile.ORIG new file mode 100644 index 00000000..83444b6d --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/Imakefile.ORIG @@ -0,0 +1,163 @@ +XCOMM Imakefile for maintaining Tcl in the Object Manager library. +XCOMM 05-Sep-93, Doug Tody NOAO/IRAF. + +#include <Library.tmpl> + +XCOMM ------------------ BEGIN TCL DEFINITIONS ---------------------- + exec_prefix = /usr/local + prefix = /usr/local + + TCL_LIBRARY = $(prefix)/lib/tcl + LIB_DIR = $(exec_prefix)/lib + BIN_DIR = $(exec_prefix)/bin + SRC_DIR = . + INCLUDE_DIR = $(prefix)/include + +#if defined(MacIIArchitecture) +XCOMM - The following are for Macintosh A/UX + GCC_FLAGS = -w -Wunused -traditional + AC_FLAGS = -DHAVE_UNISTD_H=1 -DNO_STDLIB_H=1 -DNO_STRING_H=1 \ + -DNEED_MATHERR=1 + COMPAT_OBJS = strerror.o strtoul.o tclMtherr.o + +#else +#if defined(SunArchitecture) && (OSMajorVersion <= 4) +XCOMM - The following are for SunOS + GCC_FLAGS = + AC_FLAGS = -DHAVE_UNISTD_H=1 -DNO_FLOAT_H=1 -DNO_STDLIB_H=1 \ + -DNO_STRING_H=1 -DNEED_MATHERR=1 + + COMPAT_OBJS = \ + strerror.o strtoul.o tclMtherr.o + +#else +#if defined(SunArchitecture) +XCOMM - The following are for SunSoft/Solaris + GCC_FLAGS = + AC_FLAGS = -DNO_GETWD=1 -DNO_WAIT3=1 -DHAVE_UNISTD_H=1 \ + -DNO_UNION_WAIT=1 -DNEED_MATHERR=1 + COMPAT_OBJS = tclMtherr.o + +#else +#if defined(LinuxArchitecture) + GCC_FLAGS = -DNOSTDHDRS -DSYSV -DANSI -D_BSD_SOURCE -W \ + -Wunused -Wcomment -fstrength-reduce -fpcc-struct-return + AC_FLAGS = -DHAVE_UNISTD_H=1 + COMPAT_OBJS = + +#else +#if defined(HPArchitecture) +XCOMM - The following are for HP-UX + GCC_FLAGS = + AC_FLAGS = -DNO_GETWD=1 -DNO_WAIT3=1 -DHAVE_UNISTD_H=1 \ + -DNO_UNION_WAIT=1 -DNEED_MATHERR=1 + COMPAT_OBJS = tclMtherr.o + +#else +#if defined(OSF1) + GCC_FLAGS = + AC_FLAGS = -DHAVE_UNISTD_H=1 -DNO_UNION_WAIT=1 -DNEED_MATHERR=1 + COMPAT_OBJS = tclMtherr.o +#else + GCC_FLAGS = + AC_FLAGS = + COMPAT_OBJS = +#endif +#endif +#endif +#endif +#endif +#endif + + DEPENDFLAGS = -I.. -I${SRC_DIR} ${AC_FLAGS} + CCOPTIONS = -I.. -I${SRC_DIR} ${AC_FLAGS} ${GCC_FLAGS} \ + -DTCL_LIBRARY=\"${TCL_LIBRARY}\" + +UNIX_OBJS = \ + panic.o tclEnv.o tclGlob.o tclMain.o tclUnixAZ.o \ + tclUnixStr.o tclUnixUtil.o + +GENERIC_OBJS = \ + regexp.o tclAsync.o tclBasic.o tclCkalloc.o \ + tclCmdAH.o tclCmdIL.o tclCmdMZ.o tclExpr.o tclGet.o \ + tclHash.o tclHistory.o tclLink.o tclParse.o tclProc.o \ + tclUtil.o tclVar.o + +TCL_OBJS = \ + ${GENERIC_OBJS} ${UNIX_OBJS} ${COMPAT_OBJS} +XCOMM -------------------- END TCL DEFINITIONS ---------------------- + +HEADERS = \ + patchlevel.h \ + tclRegexp.h \ + tcl.h \ + tclInt.h \ + tclUnix.h + +SRCS = \ + panic.c \ + regexp.c \ + tclAppInit.c \ + tclAsync.c \ + tclBasic.c \ + tclCkalloc.c \ + tclCmdAH.c \ + tclCmdIL.c \ + tclCmdMZ.c \ + tclEnv.c \ + tclExpr.c \ + tclGet.c \ + tclGlob.c \ + tclHash.c \ + tclHistory.c \ + tclLink.c \ + tclMain.c \ + tclMtherr.c \ + tclParse.c \ + tclProc.c \ + tclTest.c \ + tclUnixAZ.c \ + tclUnixStr.c \ + tclUnixUtil.c \ + tclUtil.c \ + tclVar.c + +OBJS = \ + ${TCL_OBJS} + +SubdirLibraryRule($(OBJS)) + +XCOMM ------------------ BEGIN TCL DEFINITIONS ---------------------- +getcwd.o: $(SRC_DIR)/compat/getcwd.c + $(CC) -c $(CCOPTIONS) $(SRC_DIR)/compat/getcwd.c + +opendir.o: $(SRC_DIR)/compat/opendir.c + $(CC) -c $(CCOPTIONS) $(SRC_DIR)/compat/opendir.c + +strerror.o: $(SRC_DIR)/compat/strerror.c + $(CC) -c $(CCOPTIONS) $(SRC_DIR)/compat/strerror.c + +strstr.o: $(SRC_DIR)/compat/strstr.c + $(CC) -c $(CCOPTIONS) $(SRC_DIR)/compat/strstr.c + +strtod.o: $(SRC_DIR)/compat/strtod.c + $(CC) -c $(CCOPTIONS) $(SRC_DIR)/compat/strtod.c + +strtol.o: $(SRC_DIR)/compat/strtol.c + $(CC) -c $(CCOPTIONS) $(SRC_DIR)/compat/strtol.c + +strtoul.o: $(SRC_DIR)/compat/strtoul.c + $(CC) -c $(CCOPTIONS) $(SRC_DIR)/compat/strtoul.c + +tmpnam.o: $(SRC_DIR)/compat/tmpnam.c + $(CC) -c $(CCOPTIONS) $(SRC_DIR)/compat/tmpnam.c + +waitpid.o: $(SRC_DIR)/compat/waitpid.c + $(CC) -c $(CCOPTIONS) $(SRC_DIR)/compat/waitpid.c +XCOMM -------------------- END TCL DEFINITIONS ---------------------- + + +NormalLintTarget($(SRCS)) +LintLibraryTarget(ar,$(SRCS)) + +DependTarget() diff --git a/vendor/x11iraf/obm/Tcl/Makefile b/vendor/x11iraf/obm/Tcl/Makefile new file mode 100644 index 00000000..4182d6a0 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/Makefile @@ -0,0 +1,1136 @@ +# Makefile generated by imake - do not edit! +# $Xorg: imake.c,v 1.6 2001/02/09 02:03:15 xorgcvs Exp $ + +# ---------------------------------------------------------------------- +# Makefile generated from "Imake.tmpl" and </tmp/IIf.t1R7HV> +# $Xorg: Imake.tmpl,v 1.4 2000/08/17 19:41:46 cpqbld Exp $ +# +# +# +# +# $XFree86: xc/config/cf/Imake.tmpl,v 3.138 2002/12/10 03:20:41 dawes Exp $ +# ---------------------------------------------------------------------- + +all:: + +.SUFFIXES: .i + +# $Xorg: Imake.cf,v 1.4 2000/08/17 19:41:45 cpqbld Exp $ + +# $XFree86: xc/config/cf/Imake.cf,v 3.80 2003/01/15 02:52:12 dawes Exp $ + +# Keep cpp from replacing path elements containing i486/i586/i686 + +# ----------------------------------------------------------------------- +# site-specific configuration parameters that need to come before +# the platform-specific parameters - edit site.def to change + +# site: $TOG: site.sample /main/r64_final/1 1998/02/05 16:28:49 kaleb $ + +# site: $XFree86: xc/config/cf/site.def,v 3.24 2000/06/25 20:17:29 dawes Exp $ + +# $XFree86: xc/config/cf/xf86site.def,v 3.181 2002/02/22 21:32:33 dawes Exp $ + +# ---------------------------------------------------------------------- +# platform-specific configuration parameters - edit linux.cf to change + +# platform: $Xorg: linux.cf,v 1.3 2000/08/17 19:41:47 cpqbld Exp $ + +# platform: $XFree86: xc/config/cf/linux.cf,v 3.201tsi Exp $ + +# operating system: Linux 2.4.29-4aslsmp i686 [ELF] (2.4.29) +# libc: (6.3.2) +# binutils: (213) + +# $Xorg: lnxLib.rules,v 1.3 2000/08/17 19:41:47 cpqbld Exp $ +# $XFree86: xc/config/cf/lnxLib.rules,v 3.43 2002/04/04 14:05:33 eich Exp $ + +# $XFree86: xc/config/cf/xfree86.cf,v 3.439.2.1 2003/03/13 04:10:40 tsi Exp $ + +# $Xorg: xfree86.cf,v 1.4 2000/08/17 19:41:49 cpqbld Exp $ + +VENDORMANNAME = XFree86 +VENDORMANVERSION = `echo 4 3 0 | sed -e 's/ /./g' -e 's/^/Version\\\ /'` + +AFB_DEFS = -DUSE_AFB + +DRIVERSDKDIR = $(USRLIBDIR)/Server +DRIVERSDKMODULEDIR = $(USRLIBDIR)/Server/modules +DRIVERSDKINCLUDEDIR = $(USRLIBDIR)/Server/include + + XF86SRC = $(SERVERSRC)/hw/xfree86 + XF86COMSRC = $(XF86SRC)/common + XF86PARSERSRC = $(XF86SRC)/parser + XF86OSSRC = $(XF86SRC)/os-support + XF86DRIVERSRC = $(XF86SRC)/drivers + DRIVERSRC = $(XF86DRIVERSRC) + + XFREE86DOCDIR = $(DOCDIR) + XFREE86PSDOCDIR = $(DOCPSDIR) + XFREE86HTMLDOCDIR = $(DOCHTMLDIR) +XFREE86JAPANESEDOCDIR = $(DOCDIR)/Japanese + +# $Xorg: xf86.rules,v 1.3 2000/08/17 19:41:48 cpqbld Exp $ + +# $XFree86: xc/config/cf/xf86.rules,v 3.33 2001/01/17 16:38:51 dawes Exp $ + +# ---------------------------------------------------------------------- +# site-specific configuration parameters that go after +# the platform-specific parameters - edit site.def to change + +# site: $TOG: site.sample /main/r64_final/1 1998/02/05 16:28:49 kaleb $ + +# site: $XFree86: xc/config/cf/site.def,v 3.24 2000/06/25 20:17:29 dawes Exp $ + +# --------------------------------------------------------------------- +# Imake rules for building libraries, programs, scripts, and data files +# rules: $Xorg: Imake.rules,v 1.3 2000/08/17 19:41:46 cpqbld Exp $ +# +# +# +# +# rules: $XFree86: xc/config/cf/Imake.rules,v 3.112 2002/11/14 21:01:13 tsi Exp $ + + _NULLCMD_ = @ echo -n + +GLIDE2INCDIR = /usr/include/glide + +GLIDE3INCDIR = /usr/include/glide3 + +GLIDE3LIBNAME = glide3 + +TKLIBNAME = + +TKLIBDIR = + +TCLLIBNAME = + +TCLIBDIR = + + PATHSEP = / + SHELL = /bin/sh -e + + TOP = ../.. + CURRENT_DIR = obm/Tcl + + IMAKE = imake + DEPEND = gccmakedep + MKDIRHIER = mkdir -p + REVPATH = revpath + EXPORTLISTGEN = + RMAN = rman + RMANBASENAME = rman + RMANOPTIONS = -f HTML + CONFIGSRC = $(TOP)/config + IMAKESRC = $(CONFIGSRC)/imake + DEPENDSRC = $(CONFIGSRC)/util + + INCROOT = /usr/X11R6/include + USRLIBDIR = /usr/X11R6/lib + VARDIR = /var + VARLIBDIR = $(VARDIR)/lib + SYSTEMUSRLIBDIR = /usr/lib + SYSTEMUSRINCDIR = /usr/include + SHLIBDIR = /usr/X11R6/lib + LINTLIBDIR = $(USRLIBDIR)/lint + MANPATH = /usr/X11R6/man + MANSOURCEPATH = $(MANPATH)/man + MANDIR = $(MANSOURCEPATH)1 + LIBMANDIR = $(MANSOURCEPATH)3 + FILEMANDIR = $(MANSOURCEPATH)5 + MISCMANDIR = $(MANSOURCEPATH)7 + DRIVERMANDIR = $(MANSOURCEPATH)4 + ICONDIR = /usr/share/icons + XCURSORPATH = "~/.icons:/usr/share/icons:/usr/share/pixmaps" + LOGDIRECTORY = $(VARDIR)/log + + VARRUNDIR = $(VARDIR)/run + + VARDBDIR = $(VARDIR)/lib + + AR = ar clq + +# Nice try but useless: make will inherit BOOTSTRAPCFLAGS +# from top Makefile + BOOTSTRAPCFLAGS = -O2 -pipe -march=i386 -mcpu=i686 -pipe + + CC = gcc -m32 + AS = gcc -m32 -c -x assembler + +.SUFFIXES: .cc + + CXX = c++ -m32 + + CXXFILT = c++filt + CXXLIB = + CXXDEBUGFLAGS = -O2 -pipe -march=i386 -mcpu=i686 -fno-strict-aliasing -pipe +CXXDEPENDINCLUDES = + CXXEXTRA_DEFINES = +CXXEXTRA_INCLUDES = + CXXSTD_DEFINES = -Dlinux -D__i386__ -D_POSIX_C_SOURCE=199309L -D_POSIX_SOURCE -D_XOPEN_SOURCE -D_BSD_SOURCE -D_SVID_SOURCE $(CXXPROJECT_DEFINES) + CXXOPTIONS = + CXXINCLUDES = $(INCLUDES) $(TOP_INCLUDES) $(CXXEXTRA_INCLUDES) + CXXDEFINES = $(CXXINCLUDES) $(CXXSTD_DEFINES) $(THREADS_CXXDEFINES) $(DEFINES) $(CXXEXTRA_DEFINES) + CXXFLAGS = $(CXXDEBUGFLAGS) $(CXXOPTIONS) $(THREADS_CXXFLAGS) $(CXXDEFINES) + + COMPRESS = compress + GZIPCMD = gzip + + CPP = /usr/bin/cpp $(STD_CPP_DEFINES) + RAWCPP = /usr/bin/cpp -undef $(STD_CPP_OPTIONS) + PREPROCESSCMD = gcc -m32 -E $(STD_CPP_DEFINES) + + INSTALL = install + INSTALLFLAGS = -c + + LD = gcc -m32 -nostdlib + + LEX = flex -l + M4 = m4 + M4FLAGS = + LEXLIB = -lfl + YACC = bison -y + CCYACC = bison -y + + LINT = lint + + LINTLIBFLAG = -C + LINTOPTS = -axz + LN = ln -s + MAKE = make + MV = mv -f + CP = cp + + RANLIB = ranlib + + RANLIBINSTFLAGS = + + RM = rm -f + PERL = perl + PERLOPTS = + MANSUFFIX = 1x + LIBMANSUFFIX = 3x + FILEMANSUFFIX = 5x + MISCMANSUFFIX = 7x + DRIVERMANSUFFIX = 4x + MANSRCSUFFIX = man + MANNEWSUFFIX = _man + MANDEFS = -D__apploaddir__=$(XAPPLOADDIR) -D__filemansuffix__=$(FILEMANSUFFIX) -D__libmansuffix__=$(LIBMANSUFFIX) -D__miscmansuffix__=$(MISCMANSUFFIX) -D__drivermansuffix__=$(DRIVERMANSUFFIX) -D__projectroot__=$(PROJECTROOT) $(XORGMANDEFS) $(VENDORMANDEFS) + + COMPRESSMANCMD = gzip -n + + TROFF = groff -Tps + NROFF = nroff + MSMACROS = -ms + MANMACROS = -man + TBL = tbl + EQN = eqn + NEQN = neqn + COL = col + COLFLAGS = -b + + MODCC = gcc -m32 + + MODCPP = /usr/bin/cpp + MODCFLAGS = $(CFLAGS) + MODAS = gcc -m32 -c -x assembler + MODASFLAGS = + + MODLD = gcc -m32 -nostdlib + + MODLDFLAGS = +MODLDCOMBINEFLAGS = -r + MODAR = ar clq + + MODRANLIB = ranlib + + STD_INCLUDES = + STD_CPP_OPTIONS = -traditional + STD_CPP_DEFINES = -traditional -Dlinux -D__i386__ -D_POSIX_C_SOURCE=199309L -D_POSIX_SOURCE -D_XOPEN_SOURCE -D_BSD_SOURCE -D_SVID_SOURCE $(PROJECT_DEFINES) + STD_DEFINES = -Dlinux -D__i386__ -D_POSIX_C_SOURCE=199309L -D_POSIX_SOURCE -D_XOPEN_SOURCE -D_BSD_SOURCE -D_SVID_SOURCE $(PROJECT_DEFINES) + EXTRA_LOAD_FLAGS = + EXTRA_LDOPTIONS = + EXTRA_LIBRARIES = + TAGS = ctags + + PARALLELMFLAGS = + + SHAREDCODEDEF = + SHLIBDEF = + + SHLIBLDFLAGS = -shared $(SHLIBGLOBALSFLAGS) + + PICFLAGS = -fPIC + + CXXPICFLAGS = -fPIC + + PROTO_DEFINES = -DFUNCPROTO=15 -DNARROWPROTO + + INSTPGMFLAGS = + + INSTBINFLAGS = -m 0755 + INSTUIDFLAGS = -m 4711 + INSTLIBFLAGS = -m 0644 + INSTINCFLAGS = -m 0444 + INSTMANFLAGS = -m 0444 + INSTDATFLAGS = -m 0444 + INSTKMEMFLAGS = -m 4711 + + PROJECTROOT = /usr/X11R6 + + CDEBUGFLAGS = -O2 -pipe -march=i386 -mcpu=i686 -fno-strict-aliasing -pipe + CCOPTIONS = + + ALLINCLUDES = $(INCLUDES) $(EXTRA_INCLUDES) $(TOP_INCLUDES) $(INSTALLED_INCLUDES) $(STD_INCLUDES) + ALLDEFINES = $(ALLINCLUDES) $(STD_DEFINES) $(PROTO_DEFINES) $(THREADS_DEFINES) $(MODULE_DEFINES) $(DEFINES) $(EXTRA_DEFINES) + CFLAGS = $(CDEBUGFLAGS) $(CCOPTIONS) $(THREADS_CFLAGS) $(MODULE_CFLAGS) $(ALLDEFINES) + LINTFLAGS = $(LINTOPTS) -DLINT $(ALLDEFINES) $(DEPEND_DEFINES) + LDPRELIB = -L$(USRLIBDIR) $(INSTALLED_LIBS) + LDPOSTLIB = + LDOPTIONS = $(CDEBUGFLAGS) $(CCOPTIONS) $(EXTRA_LDOPTIONS) $(THREADS_LDFLAGS) $(LOCAL_LDFLAGS) $(LDPRELIBS) + CXXLDOPTIONS = $(CXXDEBUGFLAGS) $(CXXOPTIONS) $(EXTRA_LDOPTIONS) $(THREADS_CXXLDFLAGS) $(LOCAL_LDFLAGS) $(LDPRELIBS) + + LDLIBS = $(LDPOSTLIBS) $(THREADS_LIBS) $(SYS_LIBRARIES) $(EXTRA_LIBRARIES) + + CCLINK = $(CC) + + CXXLINK = $(CXX) + + LDSTRIPFLAGS = -x + LDCOMBINEFLAGS = -r + DEPENDFLAGS = + DEPEND_DEFINES = + +# Not sure this belongs here + TKLIBDIR = + TKINCDIR = + TKLIBNAME = + TKLIBRARY = -L$(TKLIBDIR) -l$(TKLIBNAME) + TCLLIBDIR = + TCLINCDIR = + TCLLIBNAME = + TCLLIBRARY = -L$(TCLLIBDIR) -l$(TCLLIBNAME) + + MACROFILE = linux.cf + RM_CMD = $(RM) + + IMAKE_DEFINES = + IMAKE_WARNINGS = -Wundef + + IRULESRC = $(CONFIGDIR) + IMAKE_CMD = $(IMAKE) -DUseInstalled -I$(IRULESRC) $(IMAKE_DEFINES) $(IMAKE_WARNINGS) + + ICONFIGFILES = $(IRULESRC)/Imake.tmpl $(IRULESRC)/X11.tmpl $(IRULESRC)/site.def $(IRULESRC)/$(MACROFILE) $(IRULESRC)/xfree86.cf $(IRULESRC)/xf86.rules $(IRULESRC)/xf86site.def $(IRULESRC)/host.def $(EXTRA_ICONFIGFILES) + +# $Xorg: X11.rules,v 1.4 2000/08/17 19:41:46 cpqbld Exp $ + +# $XFree86: xc/config/cf/X11.rules,v 1.5 2000/11/06 19:24:00 dawes Exp $ + +# ---------------------------------------------------------------------- +# X Window System Build Parameters and Rules +# $Xorg: X11.tmpl,v 1.6 2000/08/17 19:41:46 cpqbld Exp $ +# +# +# +# +# $XFree86: xc/config/cf/X11.tmpl,v 1.196.2.2 2003/09/17 05:58:15 herrb Exp $ + +XORGRELSTRING = Release 6.6 +XORGMANNAME = X Version 11 + +VENDORMANNAME = XFree86 +VENDORMANVERSION = `echo 4 3 0 | sed -e 's/ /./g' -e 's/^/Version\\\ /'` + +STICKY_DEFINES = -DHAS_STICKY_DIR_BIT + +FCHOWN_DEFINES = -DHAS_FCHOWN + +# ----------------------------------------------------------------------- +# X Window System make variables; these need to be coordinated with rules + + XTOP = $(TOP) + BINDIR = /usr/X11R6/bin + BUILDINCROOT = $(TOP)/exports + BUILDINCDIR = $(BUILDINCROOT)/include + BUILDINCTOP = ../.. + BUILDLIBDIR = $(TOP)/exports/lib + BUILDLIBTOP = ../.. + BUILDBINDIR = $(TOP)/exports/bin + BUILDBINTOP = ../.. + BUILDMODULEDIR = $(BUILDLIBDIR)/modules + BUILDMODULETOP = $(BUILDLIBTOP)/.. + XBUILDINCROOT = $(XTOP)/exports + XBUILDINCDIR = $(XBUILDINCROOT)/include/X11 + XBUILDINCTOP = ../../.. + XBUILDBINDIR = $(XBUILDINCROOT)/bin + INCDIR = $(INCROOT) + ADMDIR = /var/log + LIBDIR = /usr/X11R6/lib/X11 + LIBEXECDIR = /usr/X11R6/libexec + MODULEDIR = $(USRLIBDIR)/modules + TOP_X_INCLUDES = + + ETCX11DIR = /etc/X11 + + CONFDIR = $(ETCX11DIR) + + DOCDIR = $(LIBDIR)/doc + DOCHTMLDIR = $(DOCDIR)/html + DOCPSDIR = $(DOCDIR)/PostScript + FONTDIR = $(LIBDIR)/fonts + ENCODINGSDIR = $(FONTDIR)/encodings + XINITDIR = /etc/X11/xinit + XDMDIR = /etc/X11/xdm + XDMVARDIR = $(VARLIBDIR)/xdm + TWMDIR = $(LIBDIR)/twm + XSMDIR = $(LIBDIR)/xsm + NLSDIR = $(LIBDIR)/nls + XLOCALEDIR = $(LIBDIR)/locale + PEXAPIDIR = $(LIBDIR)/PEX + LBXPROXYDIR = /etc/X11/lbxproxy + PROXYMANAGERDIR = /etc/X11/proxymngr + XPRINTDIR = /etc/X11/xserver + XAPPLOADDIR = $(LIBDIR)/app-defaults + FONTCFLAGS = -t + + INSTAPPFLAGS = $(INSTDATFLAGS) + + RGB = $(BINDIR)/rgb + FONTC = $(BINDIR)/bdftopcf + MKFONTDIR = $(BINDIR)/mkfontdir + MKHTMLINDEX = $(BINDIR)/mkhtmlindex + UCS2ANY = $(BINDIR)/ucs2any + BDFTRUNCATE = $(BINDIR)/bdftruncate + UCSMAPPREFIX = $(FONTDIR)/util/map- + XCURSORGEN = $(BINDIR)/xcursorgen + + HTMLINDEXCMD = HtmlIndexCmd + + DOCUTILSRC = $(XTOP)/doc/util + CLIENTSRC = $(TOP)/clients + DEMOSRC = $(TOP)/demos + XDOCMACROS = $(DOCUTILSRC)/macros.t + XIDXMACROS = $(DOCUTILSRC)/indexmacros.t + PROGRAMSRC = $(TOP)/programs + LIBSRC = $(XTOP)/lib + FONTSRC = $(XTOP)/fonts + ENCODINGSSRC = $(FONTSRC)/encodings + INCLUDESRC = $(BUILDINCROOT)/include + XINCLUDESRC = $(INCLUDESRC)/X11 + SERVERSRC = $(XTOP)/programs/Xserver + CONTRIBSRC = $(XTOP)/../contrib + UNSUPPORTEDSRC = $(XTOP)/unsupported + DOCSRC = $(XTOP)/doc + RGBSRC = $(XTOP)/programs/rgb + BDFTOPCFSRC = $(PROGRAMSRC)/bdftopcf + MKFONTDIRSRC = $(PROGRAMSRC)/mkfontdir + FONTSERVERSRC = $(PROGRAMSRC)/xfs + FONTINCSRC = $(XTOP)/include/fonts + EXTINCSRC = $(XTOP)/include/extensions + FTSOURCEDIR = $(TOP)/extras/FreeType + XTTSOURCEDIR = $(TOP)/extras/X-TrueType + MESASRCDIR = $(TOP)/extras/Mesa + OGLSAMPLESRCDIR = $(TOP)/extras/ogl-sample + PSWRAPSRC = $(XTOP)/config/pswrap + TRANSCOMMSRC = $(LIBSRC)/xtrans + TRANS_INCLUDES = -I$(TRANSCOMMSRC) + CONNECTION_FLAGS = -DUNIXCONN -DTCPCONN $(STICKY_DEFINES) $(FCHOWN_DEFINES) + + XORGMANDEFS = -D__xorgversion__='"$(XORGRELSTRING)" "$(XORGMANNAME)"' + VENDORMANDEFS = -D__vendorversion__="\"Version $(VENDORMANVERSION)\" $(VENDORMANNAME)" + + XENVLIBDIR = $(USRLIBDIR) + CLIENTENVSETUP = LD_LIBRARY_PATH=$(XENVLIBDIR) + +# $Xorg: lnxLib.tmpl,v 1.3 2000/08/17 19:41:47 cpqbld Exp $ +# $XFree86: xc/config/cf/lnxLib.tmpl,v 3.13 2001/01/17 16:22:32 dawes Exp $ + + XLIBSRC = $(LIBSRC)/X11 + +SOXLIBREV = 6.2 +DEPXONLYLIB = +XONLYLIB = -lX11 + +LINTXONLY = $(LINTLIBDIR)/llib-lX11.ln + + XLIBONLY = $(XONLYLIB) + + XEXTLIBSRC = $(LIBSRC)/Xext + +SOXEXTREV = 6.4 +DEPEXTENSIONLIB = +EXTENSIONLIB = -lXext + +LINTEXTENSION = $(LINTLIBDIR)/llib-lXext.ln + +LINTEXTENSIONLIB = $(LINTEXTENSION) + DEPXLIB = $(DEPEXTENSIONLIB) $(DEPXONLYLIB) + XLIB = $(EXTENSIONLIB) $(XONLYLIB) + LINTXLIB = $(LINTXONLYLIB) + + XSSLIBSRC = $(LIBSRC)/Xss + +DEPXSSLIB = $(USRLIBDIR)/libXss.a +XSSLIB = -lXss + +LINTXSS = $(LINTLIBDIR)/llib-lXss.ln + + XXF86MISCLIBSRC = $(LIBSRC)/Xxf86misc + +DEPXXF86MISCLIB = $(USRLIBDIR)/libXxf86misc.a +XXF86MISCLIB = -lXxf86misc + +LINTXXF86MISC = $(LINTLIBDIR)/llib-lXxf86misc.ln + + XXF86VMLIBSRC = $(LIBSRC)/Xxf86vm + +DEPXXF86VMLIB = $(USRLIBDIR)/libXxf86vm.a +XXF86VMLIB = -lXxf86vm + +LINTXXF86VM = $(LINTLIBDIR)/llib-lXxf86vm.ln + + XXF86DGALIBSRC = $(LIBSRC)/Xxf86dga + +DEPXXF86DGALIB = $(USRLIBDIR)/libXxf86dga.a +XXF86DGALIB = -lXxf86dga + +LINTXXF86DGA = $(LINTLIBDIR)/llib-lXxf86dga.ln + + XXF86RUSHLIBSRC = $(LIBSRC)/Xxf86rush + +DEPXXF86RUSHLIB = $(USRLIBDIR)/libXxf86rush.a +XXF86RUSHLIB = -lXxf86rush + +LINTXXF86RUSH = $(LINTLIBDIR)/llib-lXxf86rush.ln + + XVLIBSRC = $(LIBSRC)/Xv + +SOXVREV = 1.0 +DEPXVLIB = +XVLIB = -lXv + +LINTXV = $(LINTLIBDIR)/llib-lXv.ln + + XVMCLIBSRC = $(LIBSRC)/XvMC + +DEPXVMCLIB = $(USRLIBDIR)/libXvMC.a +XVMCLIB = -lXvMC + +LINTXVMC = $(LINTLIBDIR)/llib-lXvMC.ln + + XINERAMALIBSRC = $(LIBSRC)/Xinerama + +DEPXINERAMALIB = $(USRLIBDIR)/libXinerama.a +XINERAMALIB = -lXinerama + +LINTXINERAMA = $(LINTLIBDIR)/llib-lXinerama.ln + + XRESLIBSRC = $(LIBSRC)/XRes + +DEPXRESLIB = $(USRLIBDIR)/libXRes.a +XRESLIB = -lXRes + +LINTXRES = $(LINTLIBDIR)/llib-lXRes.ln + + DPSLIBSRC = $(LIBSRC)/dps + +SODPSREV = 1.0 +DEPDPSLIB = +DPSLIB = -ldps + +LINTDPS = $(LINTLIBDIR)/llib-ldps.ln + + DPSTKLIBSRC = $(LIBSRC)/dpstk + +SODPSTKREV = 1.0 +DEPDPSTKLIB = +DPSTKLIB = -ldpstk + +LINTDPSTK = $(LINTLIBDIR)/llib-ldpstk.ln + + PSRESLIBSRC = $(LIBSRC)/psres + +SOPSRESREV = 1.0 +DEPPSRESLIB = +PSRESLIB = -lpsres + +LINTPSRES = $(LINTLIBDIR)/llib-lpsres.ln + + GLULIBSRC = $(LIBSRC)/GLU + +SOGLUREV = 1.3 +DEPGLULIB = +GLULIB = -lGLU + +LINTGLU = $(LINTLIBDIR)/llib-lGLU.ln + + GLXLIBSRC = $(LIBSRC)/GL + +SOGLREV = 1.2 +DEPGLXLIB = +GLXLIB = -lGL + +LINTGLX = $(LINTLIBDIR)/llib-lGL.ln + + GLWIDGETSRC = $(LIBSRC)/GLw + +DEPGLWLIB = $(USRLIBDIR)/libGLw.a +GLWLIB = -lGLw + +LINTGLW = $(LINTLIBDIR)/llib-lGLw.ln + + XRENDERLIBSRC = $(LIBSRC)/Xrender + +SOXRENDERREV = 1.2 +DEPXRENDERLIB = +XRENDERLIB = -lXrender + +LINTXRENDER = $(LINTLIBDIR)/llib-lXrender.ln + + XRANDRRLIBSRC = $(LIBSRC)/Xrandr + +SOXRANDRREV = 2.0 +DEPXRANDRLIB = +XRANDRLIB = -lXrandr + +LINTXRANDR = $(LINTLIBDIR)/llib-lXrandr.ln + + XCURSORRLIBSRC = $(LIBSRC)/Xcursor + +SOXCURSORREV = 1.0 +DEPXCURSORLIB = +XCURSORLIB = -lXcursor + +LINTXCURSOR = $(LINTLIBDIR)/llib-lXcursor.ln + + XFONTCACHELIBSRC = $(LIBSRC)/Xfontcache + +DEPXFONTCACHELIB = $(USRLIBDIR)/libXfontcache.a +XFONTCACHELIB = -lXfontcache + +LINTXFONTCACHE = $(LINTLIBDIR)/llib-lXfontcache.ln + + XAUTHSRC = $(LIBSRC)/Xau + +DEPXAUTHLIB = $(USRLIBDIR)/libXau.a +XAUTHLIB = -lXau + +LINTXAUTH = $(LINTLIBDIR)/llib-lXau.ln + + XDMCPLIBSRC = $(LIBSRC)/Xdmcp + +DEPXDMCPLIB = $(USRLIBDIR)/libXdmcp.a +XDMCPLIB = -lXdmcp + +LINTXDMCP = $(LINTLIBDIR)/llib-lXdmcp.ln + + XMUSRC = $(LIBSRC)/Xmu + +SOXMUREV = 6.2 +DEPXMULIB = +XMULIB = -lXmu + +LINTXMU = $(LINTLIBDIR)/llib-lXmu.ln + + XMUUSRC = $(LIBSRC)/Xmuu + +SOXMUUREV = 1.0 +DEPXMUULIB = +XMUULIB = -lXmuu + +LINTXMUU = $(LINTLIBDIR)/llib-lXmuu.ln + + OLDXLIBSRC = $(LIBSRC)/oldX + +DEPOLDXLIB = $(USRLIBDIR)/liboldX.a +OLDXLIB = -loldX + +LINTOLDX = $(LINTLIBDIR)/llib-loldX.ln + + XPLIBSRC = $(LIBSRC)/Xp + +SOXPREV = 6.2 +DEPXPLIB = +XPLIB = -lXp + +LINTXP = $(LINTLIBDIR)/llib-lXp.ln + + TOOLKITSRC = $(LIBSRC)/Xt + +SOXTREV = 6.0 +DEPXTOOLONLYLIB = +XTOOLONLYLIB = -lXt + +LINTXTOOLONLY = $(LINTLIBDIR)/llib-lXt.ln + + DEPXTOOLLIB = $(DEPXTOOLONLYLIB) $(DEPSMLIB) $(DEPICELIB) + XTOOLLIB = $(XTOOLONLYLIB) $(SMLIB) $(ICELIB) + LINTXTOOLLIB = $(LINTXTOOLONLYLIB) + + XALIBSRC = $(LIBSRC)/Xa + +SOXAREV = 1.0 +DEPXALIB = +XALIB = -lXa + +LINTXA = $(LINTLIBDIR)/llib-lXa.ln + + AWIDGETSRC = $(LIBSRC)/Xaw + +SOXAWREV = 7.0 +DEPXAWLIB = +XAWLIB = -lXaw + +LINTXAW = $(LINTLIBDIR)/llib-lXaw.ln + + AWIDGET6SRC = $(LIBSRC)/Xaw6 + +SOXAW6REV = 6.1 +DEPXAW6LIB = +XAW6LIB = -lXaw + +LINTXAW6 = $(LINTLIBDIR)/llib-lXaw.ln + + XILIBSRC = $(LIBSRC)/Xi + +SOXINPUTREV = 6.0 +DEPXILIB = +XILIB = -lXi + +LINTXI = $(LINTLIBDIR)/llib-lXi.ln + + XTESTLIBSRC = $(LIBSRC)/Xtst + +SOXTESTREV = 6.1 +DEPXTESTLIB = +XTESTLIB = -lXtst + +LINTXTEST = $(LINTLIBDIR)/llib-lXtst.ln + + PEXLIBSRC = $(LIBSRC)/PEX5 + +SOPEXREV = 6.0 +DEPPEXLIB = +PEXLIB = -lPEX5 + +LINTPEX = $(LINTLIBDIR)/llib-lPEX5.ln + + XIELIBSRC = $(LIBSRC)/XIE + +SOXIEREV = 6.0 +DEPXIELIB = +XIELIB = -lXIE + +LINTXIE = $(LINTLIBDIR)/llib-lXIE.ln + + PHIGSLIBSRC = $(LIBSRC)/PHIGS + +DEPPHIGSLIB = $(USRLIBDIR)/libphigs.a +PHIGSLIB = -lphigs + +LINTPHIGS = $(LINTLIBDIR)/llib-lphigs.ln + +DEPXBSDLIB = $(USRLIBDIR)/libXbsd.a +XBSDLIB = -lXbsd + +LINTXBSD = $(LINTLIBDIR)/llib-lXbsd.ln + + ICESRC = $(LIBSRC)/ICE + +SOICEREV = 6.3 +DEPICELIB = +ICELIB = -lICE + +LINTICE = $(LINTLIBDIR)/llib-lICE.ln + + SMSRC = $(LIBSRC)/SM + +SOSMREV = 6.0 +DEPSMLIB = +SMLIB = -lSM + +LINTSM = $(LINTLIBDIR)/llib-lSM.ln + + XKEYSRC = $(LIBSRC)/Xkey + +SOXKEYREV = 6.0 +DEPXKEYLIB = +XKEYLIB = -lXkey + +LINTXKEY = $(LINTLIBDIR)/llib-lXkey.ln + + FSLIBSRC = $(LIBSRC)/FS + +DEPFSLIB = $(USRLIBDIR)/libFS.a +FSLIB = -lFS + +LINTFS = $(LINTLIBDIR)/llib-lFS.ln + + FONTLIBSRC = $(LIBSRC)/font + +SOFONTREV = 1.4 +DEPFONTLIB = +FONTLIB = -L$(FREETYPELIBDIR) -L$(FONTLIBSRC) -lXfont + +LINTXFONT = $(LINTLIBDIR)/llib-lXfont.ln +# +SOFONTREV = 1.4 +DEPXFONTLIB = +XFONTLIB = -lXfont + +LINTXFONT = $(LINTLIBDIR)/llib-lXfont.ln + + FONTSTUBLIBSRC = $(FONTLIBSRC)/stubs + +DEPFONTSTUBLIB = $(USRLIBDIR)/libfntstubs.a +FONTSTUBLIB = -lfntstubs + +LINTFONTSTUB = $(LINTLIBDIR)/llib-lfntstubs.ln + DEPFONTLIB = $(DEPXFONTLIB) $(DEPFONTSTUBLIB) + FONTLIB = $(XFONTLIB) $(FONTSTUBLIB) $(FONTFT2LIB) + + FONTENCLIBSRC = $(LIBSRC)/fontenc + +DEPXFONTENCLIB = $(USRLIBDIR)/libfontenc.a +XFONTENCLIB = -lfontenc + +LINTXFONTENC = $(LINTLIBDIR)/llib-lfontenc.ln + + XPMLIBSRC = $(LIBSRC)/Xpm + +SOXPMREV = 4.11 +DEPXPMLIB = +XPMLIB = -lXpm + +LINTXPM = $(LINTLIBDIR)/llib-lXpm.ln + +FREETYPE2DIR = /usr +FREETYPE2LIBDIR = /usr/lib +FREETYPE2INCDIR = /usr/include/freetype2 + +FREETYPE2LIB = -lfreetype + +FREETYPE2INCLUDES = -I$(FREETYPE2INCDIR) +FREETYPE2DEFINES = -DFREETYPE2 + + EXPATLIBSRC = $(LIBSRC)/expat + +SOEXPATREV = 1.0 +DEPEXPATLIB = +EXPATLIB = -lexpat + +LINTEXPAT = $(LINTLIBDIR)/llib-lexpat.ln + +EXPATDIR = /usr +EXPATLIBDIR = /usr/lib +EXPATINCDIR = /usr/include + +EXPATINCLUDES = + +EXPATLIB = -lexpat + +EXPATDEFINES = -DEXPAT + + XFT1LIBSRC = $(LIBSRC)/Xft1 + +SOXFT1REV = 1.1 +DEPXFT1LIB = +XFT1LIB = -lXft + +LINTXFT1 = $(LINTLIBDIR)/llib-lXft.ln + + XFTLIBSRC = $(LIBSRC)/Xft + +SOXFTREV = 2.1 +DEPXFTLIB = +XFTLIB = -lXft + +LINTXFT = $(LINTLIBDIR)/llib-lXft.ln + +XFTINCLUDES=$(FONTCONFIGINCLUDES) $(FREETYPE2INCLUDES) + +FONTCONFIGDIR = /usr +FONTCONFIGLIBDIR = /usr/lib +FONTCONFIGINCDIR = /usr/include +FONTCONFIGBINDIR = /usr/bin + +FONTCONFIGLIB = -lfontconfig + +FONTCONFIGINCLUDES = + +FCCACHE = $(FONTCONFIGBINDIR)/fc-cache + +FONTCONFIGDEFINES = -DFONTCONFIG + +LIBPNGINCDIR = /usr/include + +LIBPNGINC= + +LIBPNGDIR = /usr +LIBPNGLIBDIR = /usr/lib +LIBPNGINCDIR = /usr/include + +LIBPNGLIB = -lpng + + XKBFILELIBSRC = $(LIBSRC)/xkbfile + +DEPXKBFILELIB = $(USRLIBDIR)/libxkbfile.a +XKBFILELIB = -lxkbfile + +LINTXKBFILE = $(LINTLIBDIR)/llib-lxkbfile.ln + + XKBCOMPCMD = $(BINDIR)/xkbcomp + + XKBUILIBSRC = $(LIBSRC)/xkbui + +DEPXKBUILIB = $(USRLIBDIR)/libxkbui.a +XKBUILIB = -lxkbui + +LINTXKBUI = $(LINTLIBDIR)/llib-lxkbui.ln + + XTRAPLIBSRC = $(LIBSRC)/XTrap + +SOXTRAPREV = 6.4 +DEPXTRAPLIB = +XTRAPLIB = -lXTrap + +LINTXTRAP = $(LINTLIBDIR)/llib-lXTrap.ln + + DEPLIBS = $(DEPXAWLIB) $(DEPXMULIB) $(DEPXTOOLLIB) $(DEPXLIB) + + DEPLIBS1 = $(DEPLIBS) + DEPLIBS2 = $(DEPLIBS) + DEPLIBS3 = $(DEPLIBS) + DEPLIBS4 = $(DEPLIBS) + DEPLIBS5 = $(DEPLIBS) + DEPLIBS6 = $(DEPLIBS) + DEPLIBS7 = $(DEPLIBS) + DEPLIBS8 = $(DEPLIBS) + DEPLIBS9 = $(DEPLIBS) + DEPLIBS10 = $(DEPLIBS) + +XMULIBONLY = -lXmu +XMULIB = $(XMULIBONLY) $(XTOOLLIB) $(XLIB) + + CONFIGDIR = $(LIBDIR)/config + + USRLIBDIRPATH = $(USRLIBDIR) + LDPRELIBS = -L$(USRLIBDIR) $(INSTALLED_LIBS) + LDPOSTLIBS = + TOP_INCLUDES = -I$(INCROOT) $(TOP_X_INCLUDES) + PROJECT_DEFINES = + +CXXPROJECT_DEFINES = + +# ---------------------------------------------------------------------- +# start of Imakefile + +# Imakefile for maintaining Tcl in the Object Manager library. +# 05-Sep-93, Doug Tody NOAO/IRAF. +# 28-Aug-96, Mike Fitzpatrick NOAO/IRAF. (Revised) + +X11IRAFDIR = ../../ + +# $Xorg: Library.tmpl,v 1.3 2000/08/17 19:41:46 cpqbld Exp $ + +# $XFree86: xc/config/cf/Library.tmpl,v 3.20 2002/11/25 14:04:47 eich Exp $ + + CC = gcc -m32 + + CCOPTIONS = +STD_DEFINES = -Dlinux -D__i386__ -D_POSIX_C_SOURCE=199309L -D_POSIX_SOURCE -D_XOPEN_SOURCE -D_BSD_SOURCE -D_SVID_SOURCE $(PROJECT_DEFINES) +CDEBUGFLAGS = -O2 -pipe -march=i386 -mcpu=i686 -fno-strict-aliasing -pipe +CLIBDEBUGFLAGS = + CFLAGS = $(CDEBUGFLAGS) $(CLIBDEBUGFLAGS) $(CCOPTIONS) $(THREADS_CFLAGS) $(ALLDEFINES) + +LIB_MT_DEFINES = LibraryMTDefines + +SOSYMLINK = true + + X11IRAFBINDIR = $(X11IRAFDIR)/bin + X11IRAFMANDIR = $(X11IRAFDIR)/man + X11IRAFLIBDIR = $(X11IRAFDIR)/lib + X11IRAFINCDIR = $(X11IRAFDIR)/include + + XGTERMDIR = $(X11IRAFDIR)/xgterm + XIMTOOLDIR = $(X11IRAFDIR)/ximtool + XTAPEMONDIR = $(X11IRAFDIR)/xtapemon + OBMSHDIR = $(X11IRAFDIR)/obmsh + OBMDIR = $(X11IRAFDIR)/obm + XPMDIR = $(X11IRAFDIR)/xpm + XAW3DDIR = $(X11IRAFDIR)/xaw3d + CDLDIR = $(X11IRAFDIR)/cdl + + DEPLIBOBM = $(OBMDIR)/libobm.a + LIBOBM = -lobm + DEPLIBXPM = $(XPMDIR)/libXpm.a + LIBXPM = -lXpm + DEPLIBXAW3D = $(XAW3DDIR)/libXaw3d.a + LIBXAW3D = -lXaw3d + LIBCDL = -lcdl + + X11IRAF_LDFLAGS = -L$(X11IRAFDIR)/lib -L../lib + X11IRAF_INCLUDES = -I$(X11IRAFDIR)/include -I../include + + CP = cp -p + +# ------------------ BEGIN TCL DEFINITIONS ---------------------- + + TCL_LIBRARY = /usr/local/lib/tcl + SRC_DIR = . + +# - The following are for Linux + GCC_FLAGS = -DNOSTDHDRS -DSYSV -DANSI -D_BSD_SOURCE -W -fstrength-reduce -fpcc-struct-return + + AC_FLAGS = -DHAVE_UNISTD_H=1 + COMPAT_OBJS = + +# Platform flags. + + PL_FLAGS = -DUSE_STDARG + + DEPENDFLAGS = -I.. -I${SRC_DIR} ${AC_FLAGS} ${PL_FLAGS} + CCOPTIONS = -I.. -I${SRC_DIR} ${AC_FLAGS} ${PL_FLAGS} ${GCC_FLAGS} -DTCL_LIBRARY=\"${TCL_LIBRARY}\" + +UNIX_OBJS = panic.o tclEnv.o tclGlob.o tclMain.o tclUnixAZ.o tclUnixStr.o tclUnixUtil.o + +GENERIC_OBJS = regexp.o tclAsync.o tclBasic.o tclCkalloc.o tclCmdAH.o tclCmdIL.o tclCmdMZ.o tclExpr.o tclGet.o tclHash.o tclHistory.o tclLink.o tclParse.o tclProc.o tclUtil.o tclVar.o + +TCL_OBJS = ${GENERIC_OBJS} ${UNIX_OBJS} ${COMPAT_OBJS} + +# -------------------- END TCL DEFINITIONS ---------------------- + +HEADERS = patchlevel.h tclRegexp.h tcl.h tclInt.h tclUnix.h + +SRCS = panic.c regexp.c tclAppInit.c tclAsync.c tclBasic.c tclCkalloc.c tclCmdAH.c tclCmdIL.c tclCmdMZ.c tclEnv.c tclExpr.c tclGet.c tclGlob.c tclHash.c tclHistory.c tclLink.c tclMain.c tclMtherr.c tclParse.c tclProc.c tclTest.c tclUnixAZ.c tclUnixStr.c tclUnixUtil.c tclUtil.c tclVar.c + +OBJS = ${TCL_OBJS} + +all:: DONE + +DONE: $(OBJS) + $(RM) $@ + touch $@ + +cleandir:: + $(RM) DONE + +# ------------------ BEGIN TCL DEFINITIONS ---------------------- +getcwd.o: $(SRC_DIR)/compat/getcwd.c + $(CC) -c $(CCOPTIONS) $(SRC_DIR)/compat/getcwd.c + +opendir.o: $(SRC_DIR)/compat/opendir.c + $(CC) -c $(CCOPTIONS) $(SRC_DIR)/compat/opendir.c + +strerror.o: $(SRC_DIR)/compat/strerror.c + $(CC) -c $(CCOPTIONS) $(SRC_DIR)/compat/strerror.c + +strstr.o: $(SRC_DIR)/compat/strstr.c + $(CC) -c $(CCOPTIONS) $(SRC_DIR)/compat/strstr.c + +strtod.o: $(SRC_DIR)/compat/strtod.c + $(CC) -c $(CCOPTIONS) $(SRC_DIR)/compat/strtod.c + +strtol.o: $(SRC_DIR)/compat/strtol.c + $(CC) -c $(CCOPTIONS) $(SRC_DIR)/compat/strtol.c + +strtoul.o: $(SRC_DIR)/compat/strtoul.c + $(CC) -c $(CCOPTIONS) $(SRC_DIR)/compat/strtoul.c + +tmpnam.o: $(SRC_DIR)/compat/tmpnam.c + $(CC) -c $(CCOPTIONS) $(SRC_DIR)/compat/tmpnam.c + +waitpid.o: $(SRC_DIR)/compat/waitpid.c + $(CC) -c $(CCOPTIONS) $(SRC_DIR)/compat/waitpid.c +# -------------------- END TCL DEFINITIONS ---------------------- + +lint: + $(LINT) $(LINTFLAGS) $(SRCS) $(LINTLIBS) +lint1: + $(LINT) $(LINTFLAGS) $(FILE) $(LINTLIBS) + +lintlib:: llib-lar.ln + +llib-lar.ln: $(SRCS) $(EXTRALIBRARYDEPS) + $(RM) $@ + $(LINT) $(LINTLIBFLAG)ar $(LINTFLAGS) $(SRCS) + +includes:: + @if [ -d $(X11IRAFDIR)/include/Tcl ]; then \ + set +x; \ + else \ + if [ -h $(X11IRAFDIR)/include/Tcl ]; then \ + (set -x; rm -f $(X11IRAFDIR)/include/Tcl); \ + fi; \ + (set -x; $(MKDIRHIER) $(X11IRAFDIR)/include/Tcl); \ + fi + @(set -x; for i in $(HEADERS); do $(RM) $(X11IRAFDIR)/include/Tcl/$$i; $(CP) -p $(X11IRAFDIR)/obm/Tcl/$$i $(X11IRAFDIR)/include/Tcl/$$i; done) + +install:: + @(set -x; for i in $(HEADERS); do $(RM) $(X11IRAFDIR)/include/Tcl/$$i; done) + + for i in $(HEADERS); do (set -x; $(CP) -p $$i $(X11IRAFDIR)/include/Tcl/); done + +depend:: + $(DEPEND) $(DEPENDFLAGS) -- $(ALLDEFINES) $(DEPEND_DEFINES) -- $(SRCS) + +# ---------------------------------------------------------------------- +# common rules for all Makefiles - do not edit + +.c.i: + $(RM) $@ + $(CC) -E $(CFLAGS) $(_NOOP_) $*.c > $@ + +.SUFFIXES: .s + +.c.s: + $(RM) $@ + $(CC) -S $(CFLAGS) $(_NOOP_) $*.c + +emptyrule:: + +cleandir:: + $(RM) *.CKP *.ln *.BAK *.bak *.o core errs ,* *~ *.a .emacs_* tags TAGS make.log MakeOut "#"* + +Makefile:: + -@if [ -f Makefile ]; then set -x; \ + $(RM) Makefile.bak; $(MV) Makefile Makefile.bak; \ + else exit 0; fi + $(IMAKE_CMD) -DTOPDIR=$(TOP) -DCURDIR=$(CURRENT_DIR) + +tags:: + $(TAGS) -w *.[ch] + $(TAGS) -xw *.[ch] > TAGS + +man_keywords:: + +html_index:: + +clean:: cleandir + +distclean:: cleandir + +# ---------------------------------------------------------------------- +# empty rules for directories that do not have SUBDIRS - do not edit + +install:: + @echo "install in $(CURRENT_DIR) done" + +install.man:: + @echo "install.man in $(CURRENT_DIR) done" + +install.sdk:: + @echo "install.sdk in $(CURRENT_DIR) done" + +Makefiles:: + +includes:: + +depend:: + +distclean:: + $(RM) Makefile Makefile.dep + +# ---------------------------------------------------------------------- +# dependencies generated by makedepend + diff --git a/vendor/x11iraf/obm/Tcl/README b/vendor/x11iraf/obm/Tcl/README new file mode 100644 index 00000000..9cb306f5 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/README @@ -0,0 +1,346 @@ +Tcl + +by John Ousterhout +University of California at Berkeley +ouster@cs.berkeley.edu + +1. Introduction +--------------- + +This directory contains the sources and documentation for Tcl, an +embeddable tool command language. The information here corresponds +to release 7.3. + +2. Documentation +---------------- + +The best way to get started with Tcl is to read the draft of my +upcoming book on Tcl and Tk, which can be retrieved using anonymous +FTP from the directory "ucb/tcl" on ftp.cs.berkeley.edu. Part I of the +book provides an introduction to writing Tcl scripts and Part III +describes how to write C code that uses the Tcl C library procedures. + +The "doc" subdirectory in this release contains a complete set of manual +entries for Tcl. Files with extension ".1" are for programs (for +example, tclsh.1); files with extension ".3" are for C library procedures; +and files with extension ".n" describe Tcl commands. The file "doc/Tcl.n" +gives a quick summary of the Tcl language syntax. To print any of the man +pages, cd to the "doc" directory and invoke your favorite variant of +troff using the normal -man macros, for example + + ditroff -man Tcl.n + +to print Tcl.n. If Tcl has been installed correctly and your "man" +program supports it, you should be able to access the Tcl manual entries +using the normal "man" mechanisms, such as + + man Tcl + +3. Compiling and installing Tcl +------------------------------- + +This release should compile and run "out of the box" on any UNIX-like +system that approximates POSIX, BSD, or System V. I know that it runs +on workstations from Sun, DEC, H-P, IBM, and Silicon Graphics, and on +PC's running SCO UNIX and Xenix. To compile Tcl, do the following: + + (a) Type "./configure" in this directory. This runs a configuration + script created by GNU autoconf, which configures Tcl for your + system and creates a Makefile. The configure script allows you + to customize the Tcl configuration for your site; for details on + how you can do this, see the file "configure.info". + + (b) Type "make". This will create a library archive called "libtcl.a" + and an interpreter application called "tclsh" that allows you to type + Tcl commands interactively or execute script files. + + (c) If the make fails then you'll have to personalize the Makefile + for your site or possibly modify the distribution in other ways. + First check the file "porting.notes" to see if there are hints + for compiling on your system. If you need to modify Makefile, + there are comments at the beginning of it that describe the things + you might want to change and how to change them. + + (d) Type "make install" to install Tcl binaries and script files in + standard places. You'll need write permission on /usr/local to + do this. See the Makefile for details on where things get + installed. + + (e) At this point you can play with Tcl by invoking the "tclsh" + program and typing Tcl commands. However, if you haven't installed + Tcl then you'll first need to set your TCL_LIBRARY variable to + hold the full path name of the "library" subdirectory. + +If you have trouble compiling Tcl, I'd suggest looking at the file +"porting.notes". It contains information that people have sent me about +changes they had to make to compile Tcl in various environments. I make +no guarantees that this information is accurate, complete, or up-to-date, +but you may find it useful. If you get Tcl running on a new configuration, +I'd be happy to receive new information to add to "porting.notes". I'm +also interested in hearing how to change the configuration setup so that +Tcl compiles on additional platforms "out of the box". + +4. Test suite +------------- + +There is a relatively complete test suite for all of the Tcl core in +the subdirectory "tests". To use it just type "make test" in this +directory. You should then see a printout of the test files processed. +If any errors occur, you'll see a much more substantial printout for +each error. See the README file in the "tests" directory for more +information on the test suite. + +5. Summary of changes in recent releases +---------------------------------------- + +Tcl 7.3 is a minor release that includes only one change relative to +Tcl 7.1 (it fixes a portability problem that prevented tclMain.c from +compiling on some machines due to a missing R_OK definition). Tcl 7.3 +should be completely compatible with Tcl 7.1 and Tcl 7.0. + +Tcl 7.2 was a mistake; it was withdrawn shortly after it was released. + +Tcl 7.1 is a minor release that consists almost entirely of bug fixes. +The only feature change is to allow no arguments in invocations of "list" +and "concat". 7.1 should be completely compatible with 7.0. + +Tcl 7.0 is a major new release that includes several new features +and a few incompatible changes. For a complete list of all changes +to Tcl in chronological order, see the file "changes". Those changes +likely to cause compatibility problems with existing C code or Tcl +scripts are specially marked. The most important changes are +summarized below. + +Tcl configuration and installation has improved in several ways: + + 1. GNU autoconf is now used for configuring Tcl prior to compilation. + + 2. The "tclTest" program no longer exists. It has been replaced by + "tclsh", which is a true shell-like program based around Tcl (tclTest + didn't really work very well as a shell). There's a new program + "tcltest" which is the same as "tclsh" except that it includes a + few extra Tcl commands for testing purposes. + + 3. A new procedure Tcl_AppInit has been added to separate all of the + application-specific initialization from the Tcl main program. This + should make it easier to build new Tcl applications that include + extra packages. + + 4. There are now separate manual entries for each of the built-in + commands. The manual entry "Tcl.n", which used to describe all of + the built-ins plus many other things, now contains a terse but + complete description of the Tcl language syntax. + +Here is a list of all incompatibilities that affect Tcl scripts: + + 1. There have been several changes to backslash processing: + - Unknown backslash sequences such as "\*" are now replaced with + the following character (such as "*"); Tcl used to treat the + backslash as an ordinary character in these cases, so both the + backslash and the following character would be passed through. + - Backslash-newline now eats up any white space after the newline, + replacing the whole sequence with a single space character. Tcl + used to just remove the backslash and newline. + - The obsolete sequences \Cx, \Mx, \CMx, and \e no longer get + special treatment. + - The "format" command no longer does backslash processing on + its input string. + You can invoke the shell command below to locate backslash uses that + may potentially behave differently under Tcl 7.0. This command + will print all of the lines from the script files "*.tcl" that may + not work correctly under Tcl 7.0: + egrep '(\\$)|(\\[^][bfnrtv\0-9{}$ ;"])' *.tcl + In some cases the command may print lines that are actually OK. + + 2. The "glob" command now returns only the names of files that + actually exist, and it only returns names ending in "/" for + directories. + + 3. When Tcl prints floating-point numbers (e.g. in the "expr" command) + it ensures that the numbers contain a "." or "e" so that they don't + look like integers. + + 4. The "regsub" command now overwrites its result variable in all cases. + If there is no match, then the source string is copied to the result. + + 5. The "exec", "glob", "regexp", and "regsub" commands now include a + "--" switch; if the first non-switch argument starts with a "-" then + there must be a "--" switch or the non-switch argument will be treated + as a switch. + + 6. The keyword "UNIX" in the variable "errorCode" has been changed to + "POSIX". + + 7. The "format" and "scan" commands no longer support capitalized + conversion specifiers such as "%D" that aren't supported by ANSI + sprintf and sscanf. + +Here is a list of all of the incompatibilities that affect C code that +uses the Tcl library procedures. If you use an ANSI C compiler then +any potential problems will be detected when you compile your code: if +your code compiles cleanly then you don't need to worry about anything. + + 1. Tcl_TildeString now takes a dynamic string as an argument, which is + used to hold the result. + + 2. tclHash.h has been eliminated; its contents are now in tcl.h. + + 3. The Tcl_History command has been eliminated: the "history" command + is now automatically part of the interpreter. + + 4. The Tcl_Fork and Tcl_WaitPids procedures have been deleted (just + use fork and waitpid instead). + + 5. The "flags" and "termPtr" arguments to Tcl_Eval have been eliminated, + as has the "noSep" argument to Tcl_AppendElement and the TCL_NO_SPACE + flag for Tcl_SetVar and Tcl_SetVar2. + + 6. The Tcl_CmdBuf structure has been eliminated, along with the procedures + Tcl_CreateCmdBuf, Tcl_DeleteCmdBuf, and Tcl_AssembleCmd. Use dynamic + strings instead. + + 7. Tcl_UnsetVar and Tcl_UnsetVar2 now return TCL_OK or TCL_ERROR instead + of 0 or -1. + + 8. Tcl_UnixError has been renamed to Tcl_PosixError. + + 9. Tcl no longer redefines the library procedures "setenv", "putenv", + and "unsetenv" by default. You have to set up special configuration + in the Makefile if you want this. + +Below is a sampler of the most important new features in Tcl 7.0. Refer +to the "changes" file for a complete list. + + 1. The "expr" command supports transcendental and other math functions, + plus it allows you to type expressions in multiple arguments. Its + numerics have also been improved in several ways (e.g. support for + NaN). + + 2. The "format" command now supports XPG3 %n$ conversion specifiers. + + 3. The "exec" command supports many new kinds of redirection such as + >> and >&, plus it allows you to leave out the space between operators + like < and the file name. For processes put into the background, + "exec" returns a list of process ids. + + 4. The "lsearch" command now supports regular expressions and exact + matching. + + 5. The "lsort" command has several new switches to control the + sorting process (e.g. numerical sort, user-provided sort function, + reverse sort, etc.). + + 6. There's a new command "pid" that can be used to return the current + process ids or the process ids from an open file that refers to a + pipeline. + + 7. There's a new command "switch" that should now be used instead + of "case". It supports regular expressions and exact matches, and + also uses single patterns instead of pattern lists. "Case" is + now deprecated, although it's been retained for compatibility. + + 8. A new dynamic string library has been added to make it easier to + build up strings and lists of arbitrary length. See the manual entry + "DString.3". + + 9. Variable handling has been improved in several ways: you can + now use whole-array traces to create variables on demand, you can + delete variables during traces, you can upvar to array elements, + and you can retarget an upvar variable to stop through a sequence + of variables. Also, there's a new library procedure Tcl_LinkVar + that can be used to associate a C variable with a Tcl variable and + keep them in sync. + + 10. New library procedures Tcl_SetCommandInfo and Tcl_GetCommandInfo + allow you to set and get the clientData and callback procedure for + a command. + + 11. Added "-errorinfo" and "-errorcode" options to "return" command; + they allow much better error handling. + + 12. Made prompts in tclsh user-settable via "tcl_prompt1" and + "tcl_prompt2" variables. + + 13. Added low-level support that is needed to handle signals: see + Tcl_AsyncCreate, etc. + +6. Tcl newsgroup +----------------- + +There is a network news group "comp.lang.tcl" intended for the exchange +of information about Tcl, Tk, and related applications. Feel free to use +the newsgroup both for general information questions and for bug reports. +I read the newsgroup and will attempt to fix bugs and problems reported +to it. + +7. Tcl contributed archive +-------------------------- + +Many people have created exciting packages and applications based on Tcl +and made them freely available to the Tcl community. An archive of these +contributions is kept on the machine harbor.ecn.purdue.edu. You can +access the archive using anonymous FTP; the Tcl contributed archive is +in the directory "pub/tcl". The archive also contains an FAQ ("frequently +asked questions") document that provides solutions to problems that +are commonly encountered by TCL newcomers. + +8. Support and bug fixes +------------------------ + +I'm very interested in receiving bug reports and suggestions for +improvements. Bugs usually get fixed quickly (particularly if they +are serious), but enhancements may take a while and may not happen at +all unless there is widespread support for them (I'm trying to slow +the rate at which Tcl turns into a kitchen sink). It's almost impossible +to make incompatible changes to Tcl at this point. + +The Tcl community is too large for me to provide much individual +support for users. If you need help I suggest that you post questions +to comp.lang.tcl. I read the newsgroup and will attempt to answer +esoteric questions for which no-one else is likely to know the answer. +In addition, Tcl support and training are available commercially from +NeoSoft. For more information, send e-mail to "info@neosoft.com". + +9. Tcl release organization +--------------------------- + +Each Tcl release is identified by two numbers separated by a dot, e.g. +6.7 or 7.0. If a new release contains changes that are likely to break +existing C code or Tcl scripts then the major release number increments +and the minor number resets to zero: 6.0, 7.0, etc. If a new release +contains only bug fixes and compatible changes, then the minor number +increments without changing the major number, e.g. 7.1, 7.2, etc. If +you have C code or Tcl scripts that work with release X.Y, then they +should also work with any release X.Z as long as Z > Y. + +Beta releases have an additional suffix of the form bx. For example, +Tcl 7.0b1 is the first beta release of Tcl version 7.0, Tcl 7.0b2 is +the second beta release, and so on. A beta release is an initial +version of a new release, used to fix bugs and bad features before +declaring the release stable. Each new release will be preceded by +one or more beta releases. I hope that lots of people will try out +the beta releases and report problems back to me. I'll make new beta +releases to fix the problems, until eventually there is a beta release +that appears to be stable. Once this occurs I'll remove the beta +suffix so that the last beta release becomes the official release. + +If a new release contains incompatibilities (e.g. 7.0) then I can't +promise to maintain compatibility among its beta releases. For example, +release 7.0b2 may not be backward compatible with 7.0b1. I'll try +to minimize incompatibilities between beta releases, but if a major +problem turns up then I'll fix it even if it introduces an +incompatibility. Once the official release is made then there won't +be any more incompatibilities until the next release with a new major +version number. + +10. Compiling on non-UNIX systems +-------------------------------- + +The Tcl features that depend on system calls peculiar to UNIX (stat, +fork, exec, times, etc.) are now separate from the main body of Tcl, +which only requires a few generic library procedures such as malloc +and strcpy. Thus it should be relatively easy to compile Tcl for +non-UNIX machines such as MACs and DOS PC's, although a number of +UNIX-specific commands will be absent (e.g. exec, time, and glob). +See the comments at the top of Makefile for information on how to +compile without the UNIX features. diff --git a/vendor/x11iraf/obm/Tcl/README.OBM b/vendor/x11iraf/obm/Tcl/README.OBM new file mode 100644 index 00000000..bf6b891e --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/README.OBM @@ -0,0 +1,17 @@ +README for Tcl configured as part of the IRAF Object Manager Library. + +This is the standard Tcl distribution; the only difference is the addition +of an Imakefile to allow automated building of the Tcl library as part of +the Object Manager. The Imakefile should be machine independent with one +exception, the COMPAT_OBJS definition, which lists the compatibility +routines. The list of objects defined here may have to be modified for +a different host. One way to do this is to manually run "./configure" in +this directory to build the standard Tcl Makefile, then transfer the +COMPAT_OBJS entry therein to the Imakefile. + +Tcl does not need to be installed (as in make install) to be used with the +Object Manager. The contents of the Tcl library are automatically included +in libObm.a when the library is built. The Tcl include file can be +referenced as Tcl/tcl.h, with the OBM root directory specified as an -I +include directory in the application's Imakefile. In most cases the +application using OBM need not know that Tcl is used internally. diff --git a/vendor/x11iraf/obm/Tcl/changes b/vendor/x11iraf/obm/Tcl/changes new file mode 100644 index 00000000..d920add2 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/changes @@ -0,0 +1,958 @@ +Recent user-visible changes to Tcl: + +1. No more [command1] [command2] construct for grouping multiple +commands on a single command line. + +2. Semi-colon now available for grouping commands on a line. + +3. For a command to span multiple lines, must now use backslash-return +at the end of each line but the last. + +4. "Var" command has been changed to "set". + +5. Double-quotes now available as an argument grouping character. + +6. "Return" may be used at top-level. + +7. More backslash sequences available now. In particular, backslash-newline +may be used to join lines in command files. + +8. New or modified built-in commands: case, return, for, glob, info, +print, return, set, source, string, uplevel. + +9. After an error, the variable "errorInfo" is filled with a stack +trace showing what was being executed when the error occurred. + +10. Command abbreviations are accepted when parsing commands, but +are not recommended except for purely-interactive commands. + +11. $, set, and expr all complain now if a non-existent variable is +referenced. + +12. History facilities exist now. See Tcl.man and Tcl_RecordAndEval.man. + +13. Changed to distinguish between empty variables and those that don't +exist at all. Interfaces to Tcl_GetVar and Tcl_ParseVar have changed +(NULL return value is now possible). *** POTENTIAL INCOMPATIBILITY *** + +14. Changed meaning of "level" argument to "uplevel" command (1 now means +"go up one level", not "go to level 1"; "#1" means "go to level 1"). +*** POTENTIAL INCOMPATIBILITY *** + +15. 3/19/90 Added "info exists" option to see if variable exists. + +16. 3/19/90 Added "noAbbrev" variable to prohibit command abbreviations. + +17. 3/19/90 Added extra errorInfo option to "error" command. + +18. 3/21/90 Double-quotes now only affect space: command, variable, +and backslash substitutions still occur inside double-quotes. +*** POTENTIAL INCOMPATIBILITY *** + +19. 3/21/90 Added support for \r. + +20. 3/21/90 List, concat, eval, and glob commands all expect at least +one argument now. *** POTENTIAL INCOMPATIBILITY *** + +21. 3/22/90 Added "?:" operators to expressions. + +22. 3/25/90 Fixed bug in Tcl_Result that caused memory to get trashed. + +------------------- Released version 3.1 --------------------- + +23. 3/29/90 Fixed bug that caused "file a.b/c ext" to return ".b/c". + +24. 3/29/90 Semi-colon is not treated specially when enclosed in +double-quotes. + +------------------- Released version 3.2 --------------------- + +25. 4/16/90 Rewrote "exec" not to use select or signals anymore. +Should be more Sys-V compatible, and no slower in the normal case. + +26. 4/18/90 Rewrote "glob" to eliminate GNU code (there's no GNU code +left in Tcl, now), and added Tcl_TildeSubst procedure. Added automatic +tilde-substitution in many commands, including "glob". + +------------------- Released version 3.3 --------------------- + +27. 7/11/90 Added "Tcl_AppendResult" procedure. + +28. 7/20/90 "History" with no options now defaults to "history info" +rather than to "history redo". Although this is a backward incompatibility, +it should only be used interactively and thus shouldn't present any +compatibility problems with scripts. + +29. 7/20/90 Added "Tcl_GetInteger", "Tcl_GetDouble", and "Tcl_GetBoolean" +procedures. + +30. 7/22/90 Removed "Tcl_WatchInterp" procedure: doesn't seem to be +necessary, since the same effect can be achieved with the deletion +callbacks on individual commands. *** POTENTIAL INCOMPATIBILITY *** + +31. 7/23/90 Added variable tracing: Tcl_TraceVar, Tcl_UnTraceVar, +and Tcl_VarTraceInfo procedures, "trace" command. + +32. 8/9/90 Mailed out list of all bug fixes since 3.3 release. + +33. 8/29/90 Fixed bugs in Tcl_Merge relating to backslashes and +semi-colons. Mailed out patch. + +34. 9/3/90 Fixed bug in tclBasic.c: quotes weren't quoting ]'s. +Mailed out patch. + +35. 9/19/90 Rewrote exec to always use files both for input and +output to the process. The old pipe-based version didn't work if +the exec'ed process forked a child and then exited: Tcl waited +around for stdout to get closed, which didn't happen until the +grandchild exited. + +36. 11/5/90 ERR_IN_PROGRESS flag wasn't being cleared soon enough +in Tcl_Eval, allowing error messages from different commands to +pile up in $errorInfo. Fixed by re-arranging code in Tcl_Eval that +re-initializes result and ERR_IN_PROGRESS flag. Didn't mail out +patch: changes too complicated to describe. + +37. 12/19/90 Added Tcl_VarEval procedure as a convenience for +assembling and executing Tcl commands. + +38. 1/29/91 Fixed core leak in Tcl_AddErrorInfo. Also changed procedure +and Tcl_Eval so that first call to Tcl_AddErrorInfo need not come from +Tcl_Eval. + +----------------- Released version 5.0 with Tk ------------------ + +39. 4/3/91 Removed change bars from manual entries, leaving only those +that came after version 3.3 was released. + +40. 5/17/91 Changed tests to conform to Mary Ann May-Pumphrey's approach. + +41. 5/23/91 Massive revision to Tcl parser to simplify the implementation +of string and floating-point support in expressions. Newlines inside +[] are now treated as command separators rather than word separators +(this makes newline treatment consistent throughout Tcl). +*** POTENTIAL INCOMPATIBILITY *** + +42. 5/23/91 Massive rewrite of expression code to support floating-point +values and simple string comparisons. The C interfaces to expression +routines have changed (Tcl_Expr is replaced by Tcl_ExprLong, Tcl_ExprDouble, +etc.), but all old Tcl expression strings should be accepted by the new +expression code. +*** POTENTIAL INCOMPATIBILITY *** + +43. 5/23/91 Modified tclHistory.c to check for negative "keep" value. + +44. 5/23/91 Modified Tcl_Backslash to handle backslash-newline. It now +returns 0 to indicate that a backslash sequence should be replaced by +no character at all. +*** POTENTIAL INCOMPATIBILITY *** + +45. 5/29/91 Modified to use ANSI C function prototypes. Must set +"USE_ANSI" switch when compiling to get prototypes. + +46. 5/29/91 Completed test suite by providing tests for all of the +built-in Tcl commands. + +47. 5/29/91 Changed Tcl_Concat to eliminate leading and trailing +white-space in each of the things it concatenates and to ignore +elements that are empty or have only white space in them. This +produces cleaner output from the "concat" command. +*** POTENTIAL INCOMPATIBILITY *** + +48. 5/31/91 Changed "set" command and Tcl_SetVar procedure to return +new value of variable. + +49. 6/1/91 Added "while" and "cd" commands. + +50. 6/1/91 Changed "exec" to delete the last character of program +output if it is a newline. In most cases this makes it easier to +process program-generated output. +*** POTENTIAL INCOMPATIBILITY *** + +51. 6/1/91 Made sure that pointers are never used after freeing them. + +52. 6/1/91 Fixed bug in TclWordEnd where it wasn't dealing with +[] inside quotes correctly. + +53. 6/8/91 Fixed exec.test to accept return values of either 1 or +255 from "false" command. + +54. 7/6/91 Massive overhaul of variable management. Associative +arrays now available, along with "unset" command (and Tcl_UnsetVar +procedure). Variable traces have been completely reworked: +interfaces different both from Tcl and C, and multiple traces may +exist on same variable. Can no longer redefine existing local +variable to be global. Calling sequences have changed slightly +for Tcl_GetVar and Tcl_SetVar ("global" is now "flags"). Tcl_SetVar +can fail and return a NULL result. New forms of variable-manipulation +procedures: Tcl_GetVar2, Tcl_SetVar2, etc. Syntax of variable +$-notation changed to support array indexing. +*** POTENTIAL INCOMPATIBILITY *** + +55. 7/6/91 Added new list-manipulation procedures: Tcl_ScanElement, +Tcl_ConvertElement, Tcl_AppendElement. + +56. 7/12/91 Created new procedure Tcl_EvalFile, which does most of the +work of the "source" command. + +57. 7/20/91 Major reworking of "exec" command to allow pipelines, +more redirection, background. Added new procedures Tcl_Fork, +Tcl_WaitPids, Tcl_DetachPids, and Tcl_CreatePipeline. The old +"< input" notation has been replaced by "<< input" ("<" is for +redirection from a file). Also handles error returns and abnormal +terminations (e.g. signals) differently. +*** POTENTIAL INCOMPATIBILITY *** + +58. 7/21/91 Added "append" and "lappend" commands. + +59. 7/22/91 Reworked error messages and manual entries to use +?x? as the notation for an optional argument x, instead of [x]. The +bracket notation was often confused with the use of brackets for +command substitution. Also modified error messages to be more +consistent. + +60. 7/23/91 Tcl_DeleteCommand now returns an indication of whether +or not the command actually existed, and the "rename" command uses +this information to return an error if an attempt is made to delete +a non-existent command. +*** POTENTIAL INCOMPATIBILITY *** + +61. 7/25/91 Added new "errorCode" mechanism, along with procedures +Tcl_SetErrorCode, Tcl_UnixError, and Tcl_ResetResult. Renamed +Tcl_Return to Tcl_SetResult, but left a #define for Tcl_Return to +avoid compatibility problems. + +62. 7/26/91 Extended "case" command with alternate syntax where all +patterns and commands are together in a single list argument: makes +it easier to write multi-line case statements. + +63. 7/27/91 Changed "print" command to perform tilde-substitution on +the file name. + +64. 7/27/91 Added "tolower", "toupper", "trim", "trimleft", and "trimright" +options to "string" command. + +65. 7/29/91 Added "atime", "mtime", "size", and "stat" options to "file" +command. + +66. 8/1/91 Added "split" and "join" commands. + +67. 8/11/91 Added commands for file I/O, including "open", "close", +"read", "gets", "puts", "flush", "eof", "seek", and "tell". + +68. 8/14/91 Switched to use a hash table for command lookups. Command +abbreviations no longer have direct support in the Tcl interpreter, but +it should be possible to simulate them with the auto-load features +described below. The "noAbbrev" variable is no longer used by Tcl. +*** POTENTIAL INCOMPATIBILITY *** + +68.5 8/15/91 Added support for "unknown" command, which can be used to +complete abbreviations, auto-load library files, auto-exec shell +commands, etc. + +69. 8/15/91 Added -nocomplain switch to "glob" command. + +70. 8/20/91 Added "info library" option and TCL_LIBRARY #define. Also +added "info script" option. + +71. 8/20/91 Changed "file" command to take "option" argument as first +argument (before file name), for consistency with other Tcl commands. +*** POTENTIAL INCOMPATIBILITY *** + +72. 8/20/91 Changed format of information in $errorInfo variable: +comments such as + ("while" body line 1) +are now on separate lines from commands being executed. +*** POTENTIAL INCOMPATIBILITY *** + +73. 8/20/91 Changed Tcl_AppendResult so that it (eventually) frees +large buffers that it allocates. + +74. 8/21/91 Added "linsert", "lreplace", "lsearch", and "lsort" +commands. + +75. 8/28/91 Added "incr" and "exit" commands. + +76. 8/30/91 Added "regexp" and "regsub" commands. + +77. 9/4/91 Changed "dynamic" field in interpreters to "freeProc" (procedure +address). This allows for alternative storage managers. +*** POTENTIAL INCOMPATIBILITY *** + +78. 9/6/91 Added "index", "length", and "range" options to "string" +command. Added "lindex", "llength", and "lrange" commands. + +79. 9/8/91 Removed "index", "length", "print" and "range" commands. +"Print" is redundant with "puts", but less general, and the other +commands are replaced with the new commands described in change 78 +above. +*** POTENTIAL INCOMPATIBILITY *** + +80. 9/8/91 Changed history revision to occur even when history command +is nested; needed in order to allow "history" to be invoked from +"unknown" procedure. + +81. 9/13/91 Changed "panic" not to use vfprintf (it's uglier and less +general now, but makes it easier to run Tcl on systems that don't +have vfprintf). Also changed "strerror" not to redeclare sys_errlist. + +82. 9/19/91 Lots of changes to improve portability to different UNIX +systems, including addition of "config" script to adapt Tcl to the +configuration of the system it's being compiled on. + +83. 9/22/91 Added "pwd" command. + +84. 9/22/91 Renamed manual pages so that their filenames are no more +than 14 characters in length, moved to "doc" subdirectory. + +85. 9/24/91 Redid manual entries so they contain the supplemental +macros that they need; can just print with "troff -man" or "man" +now. + +86. 9/26/91 Created initial version of script library, including +a version of "unknown" that does auto-loading, auto-execution, and +abbreviation expansion. This library is used by tclTest +automatically. See the "library" manual entry for details. + +----------------- Released version 6.0, 9/26/91 ------------------ + +87. 9/30/91 Made "string tolower" and "string toupper" check case +before converting: on some systems, "tolower" and "toupper" assume +that character already has particular case. + +88. 9/30/91 Fixed bug in Tcl_SetResult: wasn't always setting freeProc +correctly when called with NULL value. This tended to cause memory +allocation errors later. + +89. 10/3/91 Added "upvar" command. + +90. 10/4/91 Changed "format" so that internally it converts %D to %ld, +%U to %lu, %O to %lo, and %F to %f. This eliminates some compatibility +problems on some machines without affecting behavior. + +91. 10/10/91 Fixed bug in "regsub" that caused core dumps with the -all +option when the last match wasn't at the end of the string. + +92. 10/17/91 Fixed problems with backslash sequences: \r support was +incomplete and \f and \v weren't supported at all. + +93. 10/24/91 Added Tcl_InitHistory procedure. + +94. 10/24/91 Changed "regexp" to store "-1 -1" in subMatchVars that +don't match, rather than returning an error. + +95. 10/27/91 Modified "regexp" to return actual strings in matchVar +and subMatchVars instead of indices. Added "-indices" switch to cause +indices to be returned. +*** POTENTIAL INCOMPATIBILITY *** + +96. 10/27/91 Fixed bug in "scan" where it used hardwired constants for +sizes of floats and doubles instead of using "sizeof". + +97. 10/31/91 Fixed bug in tclParse.c where parse-related error messages +weren't being storage-managed correctly, causing spurious free's. + +98. 10/31/91 Form feed and vertical tab characters are now considered +to be space characters by the parser. + +99. 10/31/91 Added TCL_LEAVE_ERR_MSG flag to procedures like Tcl_SetVar. + +100. 11/7/91 Fixed bug in "case" where "in" argument couldn't be omitted +if all case branches were embedded in a single list. + +101. 11/7/91 Switched to use "pid_t" and "uid_t" and other official +POSIC types and function prototypes. + +----------------- Released version 6.1, 11/7/91 ------------------ + +102. 12/2/91 Modified Tcl_ScanElement and Tcl_ConvertElement in several +ways. First, allowed caller to request that only backslashes be used +(no braces). Second, made Tcl_ConvertElement more aggressive in using +backslashes for braces and quotes. + +103. 12/5/91 Added "type", "lstat", and "readlink" options to "file" +command, plus added new "type" element to output of "stat" and "lstat" +options. + +104. 12/10/91 Manual entries had first lines that caused "man" program +to try weird preprocessor. Added blank comment lines to fix problem. + +105. 12/16/91 Fixed a few bugs in auto_mkindex proc: wasn't handling +errors properly, and hadn't been upgraded for new "regexp" syntax. + +106. 1/2/92 Fixed bug in "file" command where it didn't properly handle +a file names containing tildes where the indicated user doesn't exist. + +107. 1/2/92 Fixed lots of cases in tclUnixStr.c where two different +errno symbols (e.g. EWOULDBLOCK and EAGAIN) have the same number; Tcl +will only use one of them. + +108. 1/2/92 Lots of changes to configuration script to handle many more +systems more gracefully. E.g. should now detect the bogus strtoul that +comes with AIX and substitute Tcl's own version instead. + +----------------- Released version 6.2, 1/10/92 ------------------ + +109. 1/20/92 Config didn't have code to actually use "uid_t" variable +to set TCL_UIT_T #define. + +110. 2/10/92 Tcl_Eval didn't properly reset "numLevels" variable when +too-deep recursion occurred. + +111. 2/29/92 Added "on" and "off" to keywords accepted by Tcl_GetBoolean. + +112. 3/19/92 Config wasn't installing default version of strtod.c for +systems that don't have one in libc.a. + +113. 3/23/92 Fixed bug in tclExpr.c where numbers with leading "."s, +like 0.75, couldn't be properly substituted into expressions with +variable or command substitution. + +114. 3/25/92 Fixed bug in tclUnixAZ.c where "gets" command wasn't +checking to make sure that it was able to write the variable OK. + +115. 4/16/92 Fixed bug in tclUnixAZ.c where "read" command didn't +compute file size right for device files. + +116. 4/23/92 Fixed but in tclCmdMZ.c where "trace vinfo" was overwriting +the trace command. + +----------------- Released version 6.3, 5/1/92 ------------------ + +117. 5/1/92 Added Tcl_GlobalEval. + +118. 6/1/92 Changed auto-load facility to source files at global level. + +119. 6/8/92 Tcl_ParseVar wasn't always setting termPtr after errors, which +sometimes caused core dumps. + +120. 6/21/92 Fixed bug in initialization of regexp pattern cache. This +bug caused segmentation violations in regexp commands under some conditions. + +121. 6/22/92 Changed implementation of "glob" command to eliminate +trailing slashes on directory names: they confuse some systems. There +shouldn't be any user-visible changes in functionality except for names +in error messages not having trailing slashes. + +122. 7/2/92 Fixed bug that caused 'string match ** ""' to return 0. + +123. 7/2/92 Fixed bug in Tcl_CreateCmdBuf where it wasn't initializing +the buffer to an empty string. + +124. 7/6/92 Fixed bug in "case" command where it used NULL pattern string +after errors in the "default" clause. + +125. 7/25/92 Speeded up auto_load procedure: don't reread all the index +files unless the path has changed. + +126. 8/3/92 Changed tclUnix.h to define MAXPATHLEN from PATH_MAX, not +_POSIX_PATH_MAX. + +----------------- Released version 6.4, 8/7/92 ------------------ + +127. 8/10/92 Changed tclBasic.c so that comment lines can be continued by +putting a backslash before the newline. + +128. 8/21/92 Modified "unknown" to allow the source-ing of a file for +an auto-load to trigger other nested auto-loads, as long as there isn't +any recursion on the same command name. + +129. 8/25/92 Modified "format" command to allow " " and "+" flags, and +allow flags in any order. + +130. 9/14/92 Modified Tcl_ParseVar so that it doesn't actually attempt +to look up the variable if "noEval" mode is in effect in the interpreter +(it just parses the name). This avoids the errors that used to occur +in statements like "expr {[info exists foo] && $foo}". + +131. 9/14/92 Fixed bug in "uplevel" command where it didn't output the +correct error message if a level was specified but no command. + +132. 9/14/92 Renamed manual entries to have extensions like .3 and .n, +and added "install" target to Makefile. + +133. 9/18/92 Modified "unknown" command to emulate !!, !<num>, and +^<old>^<new> csh history substitutions. + +134. 9/21/92 Made the config script cleverer about figuring out which +switches to pass to "nm". + +135. 9/23/92 Fixed tclVar.c to be sure to copy flags when growing variables. +Used to forget about traces in progress and make extra recursive calls +on trace procs. + +136. 9/28/92 Fixed bug in auto_reset where it was unsetting variables +that might not exist. + +137. 10/7/92 Changed "parray" library procedure to print any array +accessible to caller, local or global. + +138. 10/15/92 Fixed bug where propagation of new environment variable +values among interpreters took N! time if there exist N interpreters. + +139. 10/16/92 Changed auto_reset procedure so that it also deletes any +existing procedures that are in the auto_load index (the assumption is +that they should be re-loaded to get the latest versions). + +140. 10/21/92 Fixed bug that caused lists to be incorrectly generated +for elements that contained backslash-newline sequences. + +141. 12/9/92 Added support for TCL_LIBRARY environment variable: use +it as library location if it's present. + +142. 12/9/92 Added "info complete" command, Tcl_CommandComplete procedure. + +143. 12/16/92 Changed the Makefile to check to make sure "config" has been +run (can't run config directly from the Makefile because it modifies the +Makefile; thus make has to be run again after running config). + +----------------- Released version 6.5, 12/17/92 ------------------ + +144. 12/21/92 Changed config to look in several places for libc file. + +145. 12/23/92 Added "elseif" support to if. Also, "then", "else", and +"elseif" may no longer be abbreviated. +*** POTENTIAL INCOMPATIBILITY *** + +146. 12/28/92 Changed "puts" and "read" to support initial "-nonewline" +switch instead of additional "nonewline" argument. The old form is +still supported, but it is discouraged and is no longer documented. +Also changed "puts" to make the file argument default to stdout: e.g. +"puts foo" will print foo on standard output. + +147. 1/6/93 Fixed bug whereby backslash-newline wasn't working when +typed interactively, or in "info complete". + +148. 1/22/93 Fixed bugs in "lreplace" and "linsert" where close +quotes were being lost from last element before replacement or +insertion. + +149. 1/29/93 Fixed bug in Tcl_AssembleCmd where it wasn't requiring +a newline at the end of a line before considering a command to be +complete. The bug caused some very long lines in script files to +be processed as multiple separate commands. + +150. 1/29/93 Various changes in Makefile to add more configuration +options, simplify installation, fix bugs (e.g. don't use -f switch +for cp), etc. + +151. 1/29/93 Changed "name1" and "name2" identifiers to "part1" and +"part2" to avoid name conflicts with stupid C++ implementations that +use "name1" and "name2" in a reserved way. + +152. 2/1/93 Added "putenv" procedure to replace the standard system +version so that it will work correctly with Tcl's environment handling. + +----------------- Released version 6.6, 2/5/93 ------------------ + +153. 2/10/93 Fixed bugs in config script: missing "endif" in libc loop, +and tried to use strncasecmp.c instead of strcasecmp.c. + +154. 2/10/93 Makefile improvements: added RANLIB variable for easier +Sys-V configuration, added SHELL variable for SGI systems. + +----------------- Released version 6.7, 2/11/93 ------------------ + +153. 2/6/93 Changes in backslash processing: + - \Cx, \Mx, \CMx, \e sequences no longer special + - \<newline> also eats up any space after the newline, replacing + the whole sequence with a single space character + - Hex sequences like \x24 are now supported, along with ANSI C's \a. + - "format" no longer does backslash processing on its format string + - there is no longer any special meaning to a 0 return value from + Tcl_Backslash + - unknown backslash sequences, like (e.g. \*), are replaced with + the following character (e.g. *), instead of just treating the + backslash as an ordinary character. +*** POTENTIAL INCOMPATIBILITY *** + +154. 2/6/93 Updated all copyright notices. The meaning hasn't changed +at all but the wording does a better job of protecting U.C. from +liability (according to U.C. lawyers, anyway). + +155. 2/6/93 Changed "regsub" so that it overwrites the result variable +in all cases, even if there is no match. +*** POTENTIAL INCOMPATIBILITY *** + +156. 2/8/93 Added support for XPG3 %n$ conversion specifiers to "format" +command. + +157. 2/17/93 Fixed bug in Tcl_Eval where errors due to infinite +recursion could result in core dumps. + +158. 2/17/93 Improved the auto-load mechanism to deal gracefully (i.e. +return an error) with a situation where a library file that supposedly +defines a procedure doesn't actually define it. + +159. 2/17/93 Renamed Tcl_UnixError procedure to Tcl_PosixError, and +changed errorCode variable usage to use POSIX as keyword instead of +UNIX. +*** POTENTIAL INCOMPATIBILITY *** + +160. 2/19/93 Changes to exec and process control: + - Added support for >>, >&, >>&, |&, <@, >@, and >&@ forms of redirection. + - When exec puts processes into background, it returns a list of + their pids as result. + - Added support for <file, >file, etc. (i.e. no space between + ">" and file name. + - Added -keepnewline option. + - Deleted Tcl_Fork and Tcl_WaitPids procedures (just use fork and + waitpid instead). + - Added waitpid compatibility procedure for systems that don't have + it. + - Added Tcl_ReapDetachedProcs procedure. + - Changed "exec" to return an error if there is stderr output, even + if the command returns a 0 exit status (it's always been documented + this way, but the implementation wasn't correct). + - If a process returns a non-zero exit status but doesn't generate + any diagnostic output, then Tcl generates an error message for it. +*** POTENTIAL INCOMPATIBILITY *** + +161. 2/25/93 Fixed two memory-management problems having to do with +managing the old result during variable trace callbacks. + +162. 3/1/93 Added dynamic string library: Tcl_DStringInit, Tcl_DStringAppend, +Tcl_DStringFree, Tcl_DStringResult, etc. + +163. 3/1/93 Modified glob command to only return the names of files that +exist, and to only return names ending in "/" if the file is a directory. +*** POTENTIAL INCOMPATIBILITY *** + +164. 3/19/93 Modified not to use system calls like "read" directly, +but instead to use special Tcl procedures that retry automatically +if interrupted by signals. + +165. 4/3/93 Eliminated "noSep" argument to Tcl_AppendElement, plus +TCL_NO_SPACE flag for Tcl_SetVar and Tcl_SetVar2. +*** POTENTIAL INCOMPATIBILITY *** + +166. 4/3/93 Eliminated "flags" and "termPtr" arguments to Tcl_Eval. +*** POTENTIAL INCOMPATIBILITY *** + +167. 4/3/93 Changes to expressions: + - The "expr" command now accepts multiple arguments, which are + concatenated together with space separators. + - Integers aren't automatically promoted to floating-point if they + overflow the word size: errors are generated instead. + - Tcl can now handle "NaN" and other special values if the underlying + library procedures handle them. + - When printing floating-point numbers, Tcl ensures that there is a "." + or "e" in the number, so it can't be treated as an integer accidentally. + The procedure Tcl_PrintDouble is available to provide this function + in other contexts. Also, the variable "tcl_precision" can be used + to set the precision for printing (must be a decimal number giving + digits of precision). + - Expressions now support transcendental and other functions, e.g. sin, + acos, hypot, ceil, and round. Can add new math functions with + Tcl_CreateMathFunc(). + - Boolean expressions can now have any of the string values accepted + by Tcl_GetBoolean, such as "yes" or "no". +*** POTENTIAL INCOMPATIBILITY *** + +168. 4/5/93 Changed Tcl_UnsetVar and Tcl_UnsetVar2 to return TCL_OK +or TCL_ERROR instead of 0 or -1. +*** POTENTIAL INCOMPATIBILITY *** + +169. 4/5/93 Eliminated Tcl_CmdBuf structure and associated procedures; +can use Tcl_DStrings instead. +*** POTENTIAL INCOMPATIBILITY *** + +170. 4/8/93 Changed interface to Tcl_TildeSubst to use a dynamic +string for buffer space. This makes the procedure re-entrant and +thread-safe, whereas it wasn't before. +*** POTENTIAL INCOMPATIBILITY *** + +171. 4/14/93 Eliminated tclHash.h, and moved everything from it to +tcl.h +*** POTENTIAL INCOMPATIBILITY *** + +172. 4/15/93 Eliminated Tcl_InitHistory, made "history" command always +be part of interpreter. +*** POTENTIAL INCOMPATIBILITY *** + +173. 4/16/93 Modified "file" command so that "readable" option always +exists, even on machines that don't support symbolic links (always returns +same error as if the file wasn't a symbolic link). + +174. 4/26/93 Fixed bugs in "regsub" where ^ patterns didn't get handled +right (pretended not to match when it really did, and looped infinitely +if -all was specified). + +175. 4/29/93 Various improvements in the handling of variables: + - Can create variables and array elements during a read trace. + - Can delete variables during traces (note: unset traces will be + invoked when this happens). + - Can upvar to array elements. + - Can retarget an upvar to another variable by re-issuing the + upvar command with a different "other" variable. + +176. 5/3/93 Added Tcl_GetCommandInfo, which returns info about a Tcl +command such as whether it exists and its ClientData. Also added +Tcl_SetCommandInfo, which allows any of this information to be modified +and also allows a command's delete procedure to have a different +ClientData value than its command procedure. + +177. 5/5/93 Added Tcl_RegExpMatch procedure. + +178. 5/6/93 Fixed bug in "scan" where it didn't properly handle +%% conversion specifiers. Also changed "scan" to use Tcl_PrintDouble +for printing real values. + +179. 5/7/93 Added "-exact", "-glob", and "-regexp" options to "lsearch" +command to allow different kinds of pattern matching. + +180. 5/7/93 Added many new switches to "lsort" to control the sorting +process: "-ascii", "-integer", "-real", "-command", "-increasing", +and "-decreasing". + +181. 5/10/93 Changes to file I/O: + - Modified "open" command to support a list of POSIX access flags + like {WRONLY CREAT TRUNC} in addition to current fopen-style + access modes. Also added "permissions" argument to set permissions + of newly-created files. + - Fixed Scott Bolte's bug (can close stdin etc. in application and + then re-open them with Tcl commands). + - Exported access to Tcl's file table with new procedures Tcl_EnterFile + and Tcl_GetOpenFile. + +182. 5/15/93 Added new "pid" command, which can be used to retrieve +either the current process id or a list of the process ids in a +pipeline opened with "open |..." + +183. 6/3/93 Changed to use GNU autoconfig for configuration instead of +the home-brew "config" script. Also made many other configuration-related +changes, such as using <unistd.h> instead of explicitly declaring system +calls in tclUnix.h. + +184. 6/4/93 Fixed bug where core-dumps could occur if a procedure +redefined itself (the memory for the procedure's body could get +reallocated in the middle of evaluating the body); implemented +simple reference count mechanism. + +185. 6/5/93 Changed tclIndex file format in two ways: (a) it's now +eval-ed instead of parsed, which makes it 3-4x faster; (b) the entries +in auto_index are now commands to evaluate, which allows commands to +be loaded in different ways such as dynamic-loading of C code. The +old tclIndex file format is still supported. + +186. 6/7/93 Eliminated tclTest program, added new "tclsh" program +that is more like wish (allows script files to be invoked automatically +using "#!/usr/local/bin/tclsh", makes arguments available to script, +etc.). Added support for Tcl_AppInit plus default version; this +allows new Tcl applications to be created without modifying the +main program for tclsh. + +187. 6/7/93 Fixed bug in TclWordEnd that kept backslash-newline from +working correctly in some cases during interactive input. + +188. 6/9/93 Added Tcl_LinkVar and related procedures, which automatically +keep a Tcl variable in sync with a C variable. + +189. 6/16/93 Increased maximum nesting depth from 100 to 1000. + +190. 6/16/93 Modified "trace var" command so that error messages from +within traces are returned properly as the result of the variable +access, instead of the generic "access disallowed by trace command" +message. + +191. 6/16/93 Added Tcl_CallWhenDeleted to provide callbacks when an +interpreter is deleted (same functionality as Tcl_WatchInterp, which +used to exist in versions before 6.0). + +193. 6/16/93 Added "-code" argument to "return" command; it's there +primarily for completeness, so that procedures implementing control +constructs can reflect exceptional conditions back to their callers. + +194. 6/16/93 Split up Tcl.n to make separate manual entries for each +Tcl command. Tcl.n now contains a summary of the language syntax. + +195. 6/17/93 Added new "switch" command to replace "case": allows +alternate forms of pattern matching (exact, glob, regexp), replaces +pattern lists with single patterns (but you can use "-" bodies to +share one body among several patterns), eliminates "in" noise word. +"Case" command is now obsolete. + +196. 6/17/93 Changed the "exec", "glob", "regexp", and "regsub" commands +to include a "--" switch. All initial arguments starting with "-" are now +treated as switches unless a "--" switch is present to end the list. +*** POTENTIAL INCOMPATIBILITY *** + +197. 6/17/93 Changed auto-exec so that the subprocess gets stdin, stdout, +and stderr from the parent. This allows truly interactive sub-processes +(e.g. vi) to be auto-exec'ed from a tcl shell command line. + +198. 6/18/93 Added patchlevel.h, for use in coordinating future patch +releases, and also added "info patchlevel" command to make the patch +level available to Tcl scripts. + +199. 6/19/93 Modified "glob" command so that a leading "//" in a name +gets left as is (this is needed for systems like Apollos where "//" is +the super-root; Tcl used to collapse the two slashes into a single +slash). + +200. 7/7/93 Added Tcl_SetRecursionLimit procedure so that the maximum +allowable nesting depth can be controlled for an interpreter from C. + +----------------- Released version 7.0 Beta 1, 7/9/93 ------------------ + +201. 7/12/93 Modified Tcl_GetInt and tclExpr.c so that full-precision +unsigned integers can be specified without overflow errors. + +202. 7/12/93 Configuration changes: eliminate leading blank line in +configure script; provide separate targets in Makefile for installing +binary and non-binary information; check for size_t and a few other +potentially missing typedefs; don't put tclAppInit.o into libtcl.a; +better checks for matherr support. + +203. 7/14/93 Changed tclExpr.c to check the termination pointer before +errno after strtod calls, to avoid problems with some versions of +strtod that set errno in unexpected ways. + +204. 7/16/93 Changed "scan" command to be more ANSI-conformant: +eliminated %F, %D, etc., added code to ignore "l", "h", and "L" +modifiers but always convert %e, %f, and %g with implicit "l"; +also added support for %u and %i. Also changed "format" command +to eliminate %D, %U, %O, and add %i. +*** POTENTIAL INCOMPATIBILITY *** + +205. 7/17/93 Changed "uplevel" and "upvar" so that they can be used +from global level to global level: this used to generate an error. + +206. 7/19/93 Renamed "setenv", "putenv", and "unsetenv" procedures +to avoid conflicts with system procedures with the same names. If +you want Tcl's procedures to override the system procedures, do it +in the Makefile (instructions are in the Makefile). +*** POTENTIAL INCOMPATIBILITY *** + +----------------- Released version 7.0 Beta 2, 7/21/93 ------------------ + +207. 7/21/93 Fixed bug in tclVar.c where freed memory was accidentally +used if a procedure returned an element of a local array. + +208. 7/22/93 Fixed bug in "unknown" where it didn't properly handle +errors occurring in the "auto_load" procedure, leaving its state +inconsistent. + +209. 7/23/93 Changed exec's ">2" redirection operator to "2>" for +consistency with sh. This is incompatible with earlier beta releases +of 7.0 but not with pre-7.0 releases, which didn't support either +operator. + +210. 7/28/93 Changed backslash-newline handling so that the resulting +space character *is* treated as a word separator unless the backslash +sequence is in quotes or braces. This is incompatible with 7.0b1 +and 7.0b2 but is more compatible with pre-7.0 versions that the b1 +and b2 releases were. + +211. 7/28/93 Eliminated Tcl_LinkedVarWritable, added TCL_LINK_READ_ONLY to +Tcl_LinkVar to accomplish same purpose. This change is incompatible +with earlier beta releases, but not with releases before Tcl 7.0. + +212. 7/29/93 Renamed regexp C functions so they won't clash with POSIX +regexp functions that use the same name. + +213. 8/3/93 Added "-errorinfo" and "-errorcode" options to "return" +command: these allow for much better handling of the errorInfo +and errorCode variables in some cases. + +214. 8/12/93 Changed "expr" so that % always returns a remainder with +the same sign as the divisor and absolute value smaller than the +divisor. + +215. 8/14/93 Turned off auto-exec in "unknown" unless the command +was typed interactively. This means you must use "exec" when +invoking subprocesses, unless it's a command that's typed interactively. +*** POTENTIAL INCOMPATIBILITY *** + +216. 8/14/93 Added support for tcl_prompt1 and tcl_prompt2 variables +to tclMain.c: makes prompts user-settable. + +217. 8/14/93 Added asynchronous handlers (Tcl_AsyncCreate etc.) so +that signals can be taken cleanly by Tcl applications. + +218. 8/16/93 Moved information about open files from the interpreter +structure to global variables so that a file can be opened in one +interpreter and read or written in another. + +219. 8/16/93 Removed ENV_FLAGS from Makefile, so that there's no +official support for overriding setenv, unsetenv, and putenv. + +220. 8/20/93 Various configuration improvements: coerce chars +to unsigned chars before using macros like isspace; source ~/.tclshrc +file during initialization if it exists and program is running +interactively; allow there to be directories in auto_path that don't +exist or don't have tclIndex files (ignore them); added Tcl_Init +procedure and changed Tcl_AppInit to call it. + +221. 8/21/93 Fixed bug in expr where "+", "-", and " " were all +getting treated as integers with value 0. + +222. 8/26/93 Added "tcl_interactive" variable to tclsh. + +223. 8/27/93 Added procedure Tcl_FilePermissions to return whether a +given file can be read or written or both. Modified Tcl_EnterFile +to take a permissions mask rather than separate read and write arguments. + +224. 8/28/93 Fixed performance bug in "glob" command (unnecessary call +to "access" for each file caused a 5-10x slow-down for big directories). + +----------------- Released version 7.0 Beta 3, 8/28/93 ------------------ + +225. 9/9/93 Renamed regexp.h to tclRegexp.h to avoid conflicts with system +include file by same name. + +226. 9/9/93 Added Tcl_DontCallWhenDeleted. + +227. 9/16/93 Changed not to call exit C procedure directly; instead +always invoke "exit" Tcl command so that application can redefine the +command to do additional cleanup. + +228. 9/17/93 Changed auto-exec to handle names that contain slashes +(i.e. don't use PATH for them). + +229. 9/23/93 Fixed bug in "read" and "gets" commands where they didn't +clear EOF conditions. + +----------------- Released version 7.0, 9/29/93 ------------------ + +230. 10/7/93 "Scan" command wasn't properly aligning things in memory, +so segmentation faults could arise under some circumstances. + +231. 10/7/93 Fixed bug in Tcl_ConvertElement where it forgot to +backslash leading curly brace when creating lists. + +232. 10/7/93 Eliminated dependency of tclMain.c on tclInt.h and +tclUnix.h, so that people can copy the file out of the Tcl source +directory to make modified private versions. + +233. 10/8/93 Fixed bug in auto-loader that reversed the priority order +of entries in auto_path for new-style index files. Now things are +back to the way they were before 3.0: first in auto_path is always +highest priority. + +234. 10/13/93 Fixed bug where Tcl_CommandComplete didn't recognize +comments and treat them as such. Thus if you typed the line + # { +interactively, Tcl would think that the command wasn't complete and +wait for more input before evaluating the script. + +235. 10/14/93 Fixed bug where "regsub" didn't set the output variable +if the input string was empty. + +236. 10/23/93 Fixed bug where Tcl_CreatePipeline didn't close off enough +file descriptors in child processes, causing children not to exit +properly in some cases. + +237. 10/28/93 Changed "list" and "concat" commands not to generate +errors if given zero arguments, but instead to just return an empty +string. + +----------------- Released version 7.1, 11/4/93 ------------------ + +Note: there is no 7.2 release. It was flawed and was thus withdrawn +shortly after it was released. + +238. 11/10/93 TclMain.c didn't compile on some systems because of +R_OK in call to "access". Changed to eliminate call to "access". + +----------------- Released version 7.3, 11/26/93 ------------------ diff --git a/vendor/x11iraf/obm/Tcl/compat/README b/vendor/x11iraf/obm/Tcl/compat/README new file mode 100644 index 00000000..9af4285a --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/compat/README @@ -0,0 +1,6 @@ +This directory contains various header and code files that are +used make Tcl compatible with various releases of UNIX and UNIX-like +systems. Typically, files from this directory are used to compile +Tcl when a system doesn't contain the corresponding files or when +they are known to be incorrect. When the whole world becomes POSIX- +compliant this directory should be unnecessary. diff --git a/vendor/x11iraf/obm/Tcl/compat/dirent.h b/vendor/x11iraf/obm/Tcl/compat/dirent.h new file mode 100644 index 00000000..d6adf95f --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/compat/dirent.h @@ -0,0 +1,37 @@ +/* + * dirent.h -- + * + * This file is a replacement for <dirent.h> in systems that + * support the old BSD-style <sys/dir.h> with a "struct direct". + * + * Copyright (c) 1991 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. + * + * $Header: /user6/ouster/tcl/compat/RCS/dirent.h,v 1.2 93/03/19 15:25:03 ouster Exp $ SPRITE (Berkeley) + */ + +#ifndef _DIRENT +#define _DIRENT + +#include <sys/dir.h> + +#define dirent direct + +#endif /* _DIRENT */ diff --git a/vendor/x11iraf/obm/Tcl/compat/dirent2.h b/vendor/x11iraf/obm/Tcl/compat/dirent2.h new file mode 100644 index 00000000..2f61c354 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/compat/dirent2.h @@ -0,0 +1,73 @@ +/* + * dirent.h -- + * + * Declarations of a library of directory-reading procedures + * in the POSIX style ("struct dirent"). + * + * Copyright (c) 1991 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. + * + * $Header: /user6/ouster/tcl/compat/RCS/dirent2.h,v 1.2 93/03/19 15:25:09 ouster Exp $ SPRITE (Berkeley) + */ + +#ifndef _DIRENT +#define _DIRENT + +#ifndef _TCL +#include <tcl.h> +#endif + +/* + * Dirent structure, which holds information about a single + * directory entry. + */ + +#define MAXNAMLEN 255 +#define DIRBLKSIZ 512 + +struct dirent { + long d_ino; /* Inode number of entry */ + short d_reclen; /* Length of this record */ + short d_namlen; /* Length of string in d_name */ + char d_name[MAXNAMLEN + 1]; /* Name must be no longer than this */ +}; + +/* + * State that keeps track of the reading of a directory (clients + * should never look inside this structure; the fields should + * only be accessed by the library procedures). + */ + +typedef struct _dirdesc { + int dd_fd; + long dd_loc; + long dd_size; + char dd_buf[DIRBLKSIZ]; +} DIR; + +/* + * Procedures defined for reading directories: + */ + +extern void closedir _ANSI_ARGS_((DIR *dirp)); +extern DIR * opendir _ANSI_ARGS_((char *name)); +extern struct dirent * readdir _ANSI_ARGS_((DIR *dirp)); + +#endif /* _DIRENT */ diff --git a/vendor/x11iraf/obm/Tcl/compat/float.h b/vendor/x11iraf/obm/Tcl/compat/float.h new file mode 100644 index 00000000..e5b0cb01 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/compat/float.h @@ -0,0 +1,30 @@ +/* + * float.h -- + * + * This is a dummy header file to #include in Tcl when there + * is no float.h in /usr/include. Right now this file is empty: + * Tcl contains #ifdefs to deal with the lack of definitions; + * all it needs is for the #include statement to work. + * + * Copyright (c) 1993 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. + * + * $Header: /user6/ouster/tcl/compat/RCS/float.h,v 1.1 93/04/15 16:10:39 ouster Exp $ SPRITE (Berkeley) + */ diff --git a/vendor/x11iraf/obm/Tcl/compat/getcwd.c b/vendor/x11iraf/obm/Tcl/compat/getcwd.c new file mode 100644 index 00000000..f693a53e --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/compat/getcwd.c @@ -0,0 +1,63 @@ +/* + * getcwd.c -- + * + * This file provides an implementation of the getcwd procedure + * that uses getwd, for systems with getwd but without getcwd. + * + * Copyright (c) 1993 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. + */ + +#ifndef lint +static char rcsid[] = "$Header: /user6/ouster/tcl/compat/RCS/getcwd.c,v 1.2 93/07/12 14:00:59 ouster Exp $ SPRITE (Berkeley)"; +#endif /* not lint */ + +#include "tclInt.h" +#include "tclUnix.h" + +extern char *getwd _ANSI_ARGS_((char *pathname)); + +char * +getcwd(buf, size) + char *buf; /* Where to put path for current directory. */ + size_t size; /* Number of bytes at buf. */ +{ + char realBuffer[MAXPATHLEN+1]; + int length; + + if (getwd(realBuffer) == NULL) { + /* + * There's not much we can do besides guess at an errno to + * use for the result (the error message in realBuffer isn't + * much use...). + */ + + errno = EACCES; + return NULL; + } + length = strlen(realBuffer); + if (length >= size) { + errno = ERANGE; + return NULL; + } + strcpy(buf, realBuffer); + return buf; +} + diff --git a/vendor/x11iraf/obm/Tcl/compat/limits.h b/vendor/x11iraf/obm/Tcl/compat/limits.h new file mode 100644 index 00000000..dec6d99e --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/compat/limits.h @@ -0,0 +1,34 @@ +/* + * limits.h -- + * + * This is a dummy header file to #include in Tcl when there + * is no limits.h in /usr/include. There are only a few + * definitions here; also see tclUnix.h, which already + * #defines some of the things here if they're not arleady + * defined. + * + * Copyright (c) 1991 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. + * + * $Header: /user6/ouster/tcl/compat/RCS/limits.h,v 1.3 93/04/08 16:03:59 ouster Exp $ SPRITE (Berkeley) + */ + +#define LONG_MIN 0x80000000 +#define LONG_MAX 0x7fffffff diff --git a/vendor/x11iraf/obm/Tcl/compat/opendir.c b/vendor/x11iraf/obm/Tcl/compat/opendir.c new file mode 100644 index 00000000..5602350f --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/compat/opendir.c @@ -0,0 +1,106 @@ +/* + * opendir.c -- + * + * This file provides dirent-style directory-reading procedures + * for V7 Unix systems that don't have such procedures. The + * origin of this code is unclear, but it seems to have come + * originally from Larry Wall. + * + */ + +#include "tclInt.h" +#include "tclUnix.h" + +#undef DIRSIZ +#define DIRSIZ(dp) \ + ((sizeof (struct dirent) - (MAXNAMLEN+1)) + (((dp)->d_namlen+1 + 3) &~ 3)) + +/* + * open a directory. + */ +DIR * +opendir(name) +char *name; +{ + register DIR *dirp; + register int fd; + char *myname; + + myname = ((*name == '\0') ? "." : name); + if ((fd = open(myname, 0, 0)) == -1) + return NULL; + if ((dirp = (DIR *)ckalloc(sizeof(DIR))) == NULL) { + close (fd); + return NULL; + } + dirp->dd_fd = fd; + dirp->dd_loc = 0; + return dirp; +} + +/* + * read an old style directory entry and present it as a new one + */ +#ifndef pyr +#define ODIRSIZ 14 + +struct olddirect { + ino_t od_ino; + char od_name[ODIRSIZ]; +}; +#else /* a Pyramid in the ATT universe */ +#define ODIRSIZ 248 + +struct olddirect { + long od_ino; + short od_fill1, od_fill2; + char od_name[ODIRSIZ]; +}; +#endif + +/* + * get next entry in a directory. + */ +struct dirent * +readdir(dirp) +register DIR *dirp; +{ + register struct olddirect *dp; + static struct dirent dir; + + for (;;) { + if (dirp->dd_loc == 0) { + dirp->dd_size = read(dirp->dd_fd, dirp->dd_buf, + DIRBLKSIZ); + if (dirp->dd_size <= 0) + return NULL; + } + if (dirp->dd_loc >= dirp->dd_size) { + dirp->dd_loc = 0; + continue; + } + dp = (struct olddirect *)(dirp->dd_buf + dirp->dd_loc); + dirp->dd_loc += sizeof(struct olddirect); + if (dp->od_ino == 0) + continue; + dir.d_ino = dp->od_ino; + strncpy(dir.d_name, dp->od_name, ODIRSIZ); + dir.d_name[ODIRSIZ] = '\0'; /* insure null termination */ + dir.d_namlen = strlen(dir.d_name); + dir.d_reclen = DIRSIZ(&dir); + return (&dir); + } +} + +/* + * close a directory. + */ +void +closedir(dirp) +register DIR *dirp; +{ + close(dirp->dd_fd); + dirp->dd_fd = -1; + dirp->dd_loc = 0; + ckfree((char *) dirp); +} diff --git a/vendor/x11iraf/obm/Tcl/compat/stdlib.h b/vendor/x11iraf/obm/Tcl/compat/stdlib.h new file mode 100644 index 00000000..9aec51a5 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/compat/stdlib.h @@ -0,0 +1,59 @@ +/* + * stdlib.h -- + * + * Declares facilities exported by the "stdlib" portion of + * the C library. This file isn't complete in the ANSI-C + * sense; it only declares things that are needed by Tcl. + * This file is needed even on many systems with their own + * stdlib.h (e.g. SunOS) because not all stdlib.h files + * declare all the procedures needed here (such as strtod). + * + * Copyright (c) 1991 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. + * + * $Header: /user6/ouster/tcl/compat/RCS/stdlib.h,v 1.8 93/03/19 15:25:31 ouster Exp $ SPRITE (Berkeley) + */ + +#ifndef _STDLIB +#define _STDLIB + +#include <tcl.h> + +extern void abort _ANSI_ARGS_((void)); +extern double atof _ANSI_ARGS_((CONST char *string)); +extern int atoi _ANSI_ARGS_((CONST char *string)); +extern long atol _ANSI_ARGS_((CONST char *string)); +extern char * calloc _ANSI_ARGS_((unsigned int numElements, + unsigned int size)); +extern void exit _ANSI_ARGS_((int status)); +extern int free _ANSI_ARGS_((char *blockPtr)); +extern char * getenv _ANSI_ARGS_((CONST char *name)); +extern char * malloc _ANSI_ARGS_((unsigned int numBytes)); +extern void qsort _ANSI_ARGS_((VOID *base, int n, int size, + int (*compar)(CONST VOID *element1, CONST VOID + *element2))); +extern char * realloc _ANSI_ARGS_((char *ptr, unsigned int numBytes)); +extern double strtod _ANSI_ARGS_((CONST char *string, char **endPtr)); +extern long strtol _ANSI_ARGS_((CONST char *string, char **endPtr, + int base)); +extern unsigned long strtoul _ANSI_ARGS_((CONST char *string, + char **endPtr, int base)); + +#endif /* _STDLIB */ diff --git a/vendor/x11iraf/obm/Tcl/compat/strerror.c b/vendor/x11iraf/obm/Tcl/compat/strerror.c new file mode 100644 index 00000000..773b9d5e --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/compat/strerror.c @@ -0,0 +1,484 @@ +/* + * strerror.c -- + * + * Source code for the "strerror" library routine. + * + * Copyright (c) 1991-1993 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. + */ + +#ifndef lint +static char rcsid[] = "$Header: /user6/ouster/tcl/compat/RCS/strerror.c,v 1.8 93/10/28 16:32:16 ouster Exp $ SPRITE (Berkeley)"; +#endif /* not lint */ + +#include "tclInt.h" +#include "tclUnix.h" + +extern int sys_nerr; +extern char *sys_errlist[]; +/* + *---------------------------------------------------------------------- + * + * strerror -- + * + * Map an integer error number into a printable string. + * + * Results: + * The return value is a pointer to a string describing + * error. The first character of string isn't capitalized. + * + * Side effects: + * Each call to this procedure may overwrite the value returned + * by the previous call. + * + *---------------------------------------------------------------------- + */ + +char * +strerror(error) + int error; /* Integer identifying error (must be + * one of the officially-defined Sprite + * errors, as defined in errno.h). */ +{ + static char msg[50]; + +#ifndef NO_SYS_ERRLIST + if ((error <= sys_nerr) && (error > 0)) { + return sys_errlist[error]; + } +#else + switch (error) { +#ifdef E2BIG + case E2BIG: return "argument list too long"; +#endif +#ifdef EACCES + case EACCES: return "permission denied"; +#endif +#ifdef EADDRINUSE + case EADDRINUSE: return "address already in use"; +#endif +#ifdef EADDRNOTAVAIL + case EADDRNOTAVAIL: return "can't assign requested address"; +#endif +#ifdef EADV + case EADV: return "advertise error"; +#endif +#ifdef EAFNOSUPPORT + case EAFNOSUPPORT: return "address family not supported by protocol family"; +#endif +#ifdef EAGAIN + case EAGAIN: return "no more processes"; +#endif +#ifdef EALIGN + case EALIGN: return "EALIGN"; +#endif +#ifdef EALREADY + case EALREADY: return "operation already in progress"; +#endif +#ifdef EBADE + case EBADE: return "bad exchange descriptor"; +#endif +#ifdef EBADF + case EBADF: return "bad file number"; +#endif +#ifdef EBADFD + case EBADFD: return "file descriptor in bad state"; +#endif +#ifdef EBADMSG + case EBADMSG: return "not a data message"; +#endif +#ifdef EBADR + case EBADR: return "bad request descriptor"; +#endif +#ifdef EBADRPC + case EBADRPC: return "RPC structure is bad"; +#endif +#ifdef EBADRQC + case EBADRQC: return "bad request code"; +#endif +#ifdef EBADSLT + case EBADSLT: return "invalid slot"; +#endif +#ifdef EBFONT + case EBFONT: return "bad font file format"; +#endif +#ifdef EBUSY + case EBUSY: return "mount device busy"; +#endif +#ifdef ECHILD + case ECHILD: return "no children"; +#endif +#ifdef ECHRNG + case ECHRNG: return "channel number out of range"; +#endif +#ifdef ECOMM + case ECOMM: return "communication error on send"; +#endif +#ifdef ECONNABORTED + case ECONNABORTED: return "software caused connection abort"; +#endif +#ifdef ECONNREFUSED + case ECONNREFUSED: return "connection refused"; +#endif +#ifdef ECONNRESET + case ECONNRESET: return "connection reset by peer"; +#endif +#if defined(EDEADLK) && (!defined(EWOULDBLOCK) || (EDEADLK != EWOULDBLOCK)) + case EDEADLK: return "resource deadlock avoided"; +#endif +#ifdef EDEADLOCK + case EDEADLOCK: return "resource deadlock avoided"; +#endif +#ifdef EDESTADDRREQ + case EDESTADDRREQ: return "destination address required"; +#endif +#ifdef EDIRTY + case EDIRTY: return "mounting a dirty fs w/o force"; +#endif +#ifdef EDOM + case EDOM: return "math argument out of range"; +#endif +#ifdef EDOTDOT + case EDOTDOT: return "cross mount point"; +#endif +#ifdef EDQUOT + case EDQUOT: return "disk quota exceeded"; +#endif +#ifdef EDUPPKG + case EDUPPKG: return "duplicate package name"; +#endif +#ifdef EEXIST + case EEXIST: return "file already exists"; +#endif +#ifdef EFAULT + case EFAULT: return "bad address in system call argument"; +#endif +#ifdef EFBIG + case EFBIG: return "file too large"; +#endif +#ifdef EHOSTDOWN + case EHOSTDOWN: return "host is down"; +#endif +#ifdef EHOSTUNREACH + case EHOSTUNREACH: return "host is unreachable"; +#endif +#ifdef EIDRM + case EIDRM: return "identifier removed"; +#endif +#ifdef EINIT + case EINIT: return "initialization error"; +#endif +#ifdef EINPROGRESS + case EINPROGRESS: return "operation now in progress"; +#endif +#ifdef EINTR + case EINTR: return "interrupted system call"; +#endif +#ifdef EINVAL + case EINVAL: return "invalid argument"; +#endif +#ifdef EIO + case EIO: return "I/O error"; +#endif +#ifdef EISCONN + case EISCONN: return "socket is already connected"; +#endif +#ifdef EISDIR + case EISDIR: return "illegal operation on a directory"; +#endif +#ifdef EISNAME + case EISNAM: return "is a name file"; +#endif +#ifdef ELBIN + case ELBIN: return "ELBIN"; +#endif +#ifdef EL2HLT + case EL2HLT: return "level 2 halted"; +#endif +#ifdef EL2NSYNC + case EL2NSYNC: return "level 2 not synchronized"; +#endif +#ifdef EL3HLT + case EL3HLT: return "level 3 halted"; +#endif +#ifdef EL3RST + case EL3RST: return "level 3 reset"; +#endif +#ifdef ELIBACC + case ELIBACC: return "can not access a needed shared library"; +#endif +#ifdef ELIBBAD + case ELIBBAD: return "accessing a corrupted shared library"; +#endif +#ifdef ELIBEXEC + case ELIBEXEC: return "can not exec a shared library directly"; +#endif +#ifdef ELIBMAX + case ELIBMAX: return + "attempting to link in more shared libraries than system limit"; +#endif +#ifdef ELIBSCN + case ELIBSCN: return ".lib section in a.out corrupted"; +#endif +#ifdef ELNRNG + case ELNRNG: return "link number out of range"; +#endif +#ifdef ELOOP + case ELOOP: return "too many levels of symbolic links"; +#endif +#ifdef EMFILE + case EMFILE: return "too many open files"; +#endif +#ifdef EMLINK + case EMLINK: return "too many links"; +#endif +#ifdef EMSGSIZE + case EMSGSIZE: return "message too long"; +#endif +#ifdef EMULTIHOP + case EMULTIHOP: return "multihop attempted"; +#endif +#ifdef ENAMETOOLONG + case ENAMETOOLONG: return "file name too long"; +#endif +#ifdef ENAVAIL + case ENAVAIL: return "not available"; +#endif +#ifdef ENET + case ENET: return "ENET"; +#endif +#ifdef ENETDOWN + case ENETDOWN: return "network is down"; +#endif +#ifdef ENETRESET + case ENETRESET: return "network dropped connection on reset"; +#endif +#ifdef ENETUNREACH + case ENETUNREACH: return "network is unreachable"; +#endif +#ifdef ENFILE + case ENFILE: return "file table overflow"; +#endif +#ifdef ENOANO + case ENOANO: return "anode table overflow"; +#endif +#if defined(ENOBUFS) && (!defined(ENOSR) || (ENOBUFS != ENOSR)) + case ENOBUFS: return "no buffer space available"; +#endif +#ifdef ENOCSI + case ENOCSI: return "no CSI structure available"; +#endif +#ifdef ENODATA + case ENODATA: return "no data available"; +#endif +#ifdef ENODEV + case ENODEV: return "no such device"; +#endif +#ifdef ENOENT + case ENOENT: return "no such file or directory"; +#endif +#ifdef ENOEXEC + case ENOEXEC: return "exec format error"; +#endif +#ifdef ENOLCK + case ENOLCK: return "no locks available"; +#endif +#ifdef ENOLINK + case ENOLINK: return "link has be severed"; +#endif +#ifdef ENOMEM + case ENOMEM: return "not enough memory"; +#endif +#ifdef ENOMSG + case ENOMSG: return "no message of desired type"; +#endif +#ifdef ENONET + case ENONET: return "machine is not on the network"; +#endif +#ifdef ENOPKG + case ENOPKG: return "package not installed"; +#endif +#ifdef ENOPROTOOPT + case ENOPROTOOPT: return "bad proocol option"; +#endif +#ifdef ENOSPC + case ENOSPC: return "no space left on device"; +#endif +#ifdef ENOSR + case ENOSR: return "out of stream resources"; +#endif +#ifdef ENOSTR + case ENOSTR: return "not a stream device"; +#endif +#ifdef ENOSYM + case ENOSYM: return "unresolved symbol name"; +#endif +#ifdef ENOSYS + case ENOSYS: return "function not implemented"; +#endif +#ifdef ENOTBLK + case ENOTBLK: return "block device required"; +#endif +#ifdef ENOTCONN + case ENOTCONN: return "socket is not connected"; +#endif +#ifdef ENOTDIR + case ENOTDIR: return "not a directory"; +#endif +#ifdef ENOTEMPTY + case ENOTEMPTY: return "directory not empty"; +#endif +#ifdef ENOTNAM + case ENOTNAM: return "not a name file"; +#endif +#ifdef ENOTSOCK + case ENOTSOCK: return "socket operation on non-socket"; +#endif +#ifdef ENOTTY + case ENOTTY: return "inappropriate device for ioctl"; +#endif +#ifdef ENOTUNIQ + case ENOTUNIQ: return "name not unique on network"; +#endif +#ifdef ENXIO + case ENXIO: return "no such device or address"; +#endif +#ifdef EOPNOTSUPP + case EOPNOTSUPP: return "operation not supported on socket"; +#endif +#ifdef EPERM + case EPERM: return "not owner"; +#endif +#ifdef EPFNOSUPPORT + case EPFNOSUPPORT: return "protocol family not supported"; +#endif +#ifdef EPIPE + case EPIPE: return "broken pipe"; +#endif +#ifdef EPROCLIM + case EPROCLIM: return "too many processes"; +#endif +#ifdef EPROCUNAVAIL + case EPROCUNAVAIL: return "bad procedure for program"; +#endif +#ifdef EPROGMISMATCH + case EPROGMISMATCH: return "program version wrong"; +#endif +#ifdef EPROGUNAVAIL + case EPROGUNAVAIL: return "RPC program not available"; +#endif +#ifdef EPROTO + case EPROTO: return "protocol error"; +#endif +#ifdef EPROTONOSUPPORT + case EPROTONOSUPPORT: return "protocol not suppored"; +#endif +#ifdef EPROTOTYPE + case EPROTOTYPE: return "protocol wrong type for socket"; +#endif +#ifdef ERANGE + case ERANGE: return "math result unrepresentable"; +#endif +#if defined(EREFUSED) && (!defined(ECONNREFUSED) || (EREFUSED != ECONNREFUSED)) + case EREFUSED: return "EREFUSED"; +#endif +#ifdef EREMCHG + case EREMCHG: return "remote address changed"; +#endif +#ifdef EREMDEV + case EREMDEV: return "remote device"; +#endif +#ifdef EREMOTE + case EREMOTE: return "pathname hit remote file system"; +#endif +#ifdef EREMOTEIO + case EREMOTEIO: return "remote i/o error"; +#endif +#ifdef EREMOTERELEASE + case EREMOTERELEASE: return "EREMOTERELEASE"; +#endif +#ifdef EROFS + case EROFS: return "read-only file system"; +#endif +#ifdef ERPCMISMATCH + case ERPCMISMATCH: return "RPC version is wrong"; +#endif +#ifdef ERREMOTE + case ERREMOTE: return "object is remote"; +#endif +#ifdef ESHUTDOWN + case ESHUTDOWN: return "can't send afer socket shutdown"; +#endif +#ifdef ESOCKTNOSUPPORT + case ESOCKTNOSUPPORT: return "socket type not supported"; +#endif +#ifdef ESPIPE + case ESPIPE: return "invalid seek"; +#endif +#ifdef ESRCH + case ESRCH: return "no such process"; +#endif +#ifdef ESRMNT + case ESRMNT: return "srmount error"; +#endif +#ifdef ESTALE + case ESTALE: return "stale remote file handle"; +#endif +#ifdef ESUCCESS + case ESUCCESS: return "Error 0"; +#endif +#ifdef ETIME + case ETIME: return "timer expired"; +#endif +#ifdef ETIMEDOUT + case ETIMEDOUT: return "connection timed out"; +#endif +#ifdef ETOOMANYREFS + case ETOOMANYREFS: return "too many references: can't splice"; +#endif +#ifdef ETXTBSY + case ETXTBSY: return "text file or pseudo-device busy"; +#endif +#ifdef EUCLEAN + case EUCLEAN: return "structure needs cleaning"; +#endif +#ifdef EUNATCH + case EUNATCH: return "protocol driver not attached"; +#endif +#ifdef EUSERS + case EUSERS: return "too many users"; +#endif +#ifdef EVERSION + case EVERSION: return "version mismatch"; +#endif +#if defined(EWOULDBLOCK) && (!defined(EAGAIN) || (EWOULDBLOCK != EAGAIN)) + case EWOULDBLOCK: return "operation would block"; +#endif +#ifdef EXDEV + case EXDEV: return "cross-domain link"; +#endif +#ifdef EXFULL + case EXFULL: return "message tables full"; +#endif + } +#endif /* ! NO_SYS_ERRLIST */ + sprintf(msg, "unknown error (%d)", error); + return msg; +} diff --git a/vendor/x11iraf/obm/Tcl/compat/string.h b/vendor/x11iraf/obm/Tcl/compat/string.h new file mode 100644 index 00000000..863961f7 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/compat/string.h @@ -0,0 +1,78 @@ +/* + * string.h -- + * + * Declarations of ANSI C library procedures for string handling. + * + * Copyright (c) 1991-1993 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. + * + * $Header: /user6/ouster/tcl/compat/RCS/string.h,v 1.9 93/03/19 15:25:36 ouster Exp $ SPRITE (Berkeley) + */ + +#ifndef _STRING +#define _STRING + +#include <tcl.h> + +/* + * The following #include is needed to define size_t. (This used to + * include sys/stdtypes.h but that doesn't exist on older versions + * of SunOS, e.g. 4.0.2, so I'm trying sys/types.h now.... hopefully + * it exists everywhere) + */ + +#include <sys/types.h> + +extern char * memchr _ANSI_ARGS_((CONST VOID *s, int c, size_t n)); +extern int memcmp _ANSI_ARGS_((CONST VOID *s1, CONST VOID *s2, + size_t n)); +extern char * memcpy _ANSI_ARGS_((VOID *t, CONST VOID *f, size_t n)); +extern char * memmove _ANSI_ARGS_((VOID *t, CONST VOID *f, + size_t n)); +extern char * memset _ANSI_ARGS_((VOID *s, int c, size_t n)); + +extern int strcasecmp _ANSI_ARGS_((CONST char *s1, + CONST char *s2)); +extern char * strcat _ANSI_ARGS_((char *dst, CONST char *src)); +extern char * strchr _ANSI_ARGS_((CONST char *string, int c)); +extern int strcmp _ANSI_ARGS_((CONST char *s1, CONST char *s2)); +extern char * strcpy _ANSI_ARGS_((char *dst, CONST char *src)); +extern size_t strcspn _ANSI_ARGS_((CONST char *string, + CONST char *chars)); +extern char * strdup _ANSI_ARGS_((CONST char *string)); +extern char * strerror _ANSI_ARGS_((int error)); +extern size_t strlen _ANSI_ARGS_((CONST char *string)); +extern int strncasecmp _ANSI_ARGS_((CONST char *s1, + CONST char *s2, size_t n)); +extern char * strncat _ANSI_ARGS_((char *dst, CONST char *src, + size_t numChars)); +extern int strncmp _ANSI_ARGS_((CONST char *s1, CONST char *s2, + size_t nChars)); +extern char * strncpy _ANSI_ARGS_((char *dst, CONST char *src, + size_t numChars)); +extern char * strpbrk _ANSI_ARGS_((CONST char *string, char *chars)); +extern char * strrchr _ANSI_ARGS_((CONST char *string, int c)); +extern size_t strspn _ANSI_ARGS_((CONST char *string, + CONST char *chars)); +extern char * strstr _ANSI_ARGS_((CONST char *string, + CONST char *substring)); +extern char * strtok _ANSI_ARGS_((CONST char *s, CONST char *delim)); + +#endif /* _STRING */ diff --git a/vendor/x11iraf/obm/Tcl/compat/strstr.c b/vendor/x11iraf/obm/Tcl/compat/strstr.c new file mode 100644 index 00000000..4fd5e1bc --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/compat/strstr.c @@ -0,0 +1,84 @@ +/* + * strstr.c -- + * + * Source code for the "strstr" library routine. + * + * Copyright (c) 1988-1993 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. + */ + +#ifndef lint +static char rcsid[] = "$Header: /user6/ouster/tcl/compat/RCS/strstr.c,v 1.2 93/03/19 15:25:40 ouster Exp $ SPRITE (Berkeley)"; +#endif /* not lint */ + +/* + *---------------------------------------------------------------------- + * + * strstr -- + * + * Locate the first instance of a substring in a string. + * + * Results: + * If string contains substring, the return value is the + * location of the first matching instance of substring + * in string. If string doesn't contain substring, the + * return value is 0. Matching is done on an exact + * character-for-character basis with no wildcards or special + * characters. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +char * +strstr(string, substring) + register char *string; /* String to search. */ + char *substring; /* Substring to try to find in string. */ +{ + register char *a, *b; + + /* First scan quickly through the two strings looking for a + * single-character match. When it's found, then compare the + * rest of the substring. + */ + + b = substring; + if (*b == 0) { + return string; + } + for ( ; *string != 0; string += 1) { + if (*string != *b) { + continue; + } + a = string; + while (1) { + if (*b == 0) { + return string; + } + if (*a++ != *b++) { + break; + } + } + b = substring; + } + return (char *) 0; +} diff --git a/vendor/x11iraf/obm/Tcl/compat/strtod.c b/vendor/x11iraf/obm/Tcl/compat/strtod.c new file mode 100644 index 00000000..eb4b3234 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/compat/strtod.c @@ -0,0 +1,273 @@ +/* + * strtod.c -- + * + * Source code for the "strtod" library procedure. + * + * Copyright (c) 1988-1993 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. + */ + +#ifndef lint +static char rcsid[] = "$Header: /user6/ouster/tcl/compat/RCS/strtod.c,v 1.6 93/07/23 16:31:17 ouster Exp $ SPRITE (Berkeley)"; +#endif /* not lint */ + +#include "tcl.h" +#ifdef NO_STDLIB_H +# include "compat/stdlib.h" +#else +# include <stdlib.h> +#endif +#include <ctype.h> + +#ifndef TRUE +#define TRUE 1 +#define FALSE 0 +#endif +#ifndef NULL +#define NULL 0 +#endif + +static int maxExponent = 511; /* Largest possible base 10 exponent. Any + * exponent larger than this will already + * produce underflow or overflow, so there's + * no need to worry about additional digits. + */ +static double powersOf10[] = { /* Table giving binary powers of 10. Entry */ + 10., /* is 10^2^i. Used to convert decimal */ + 100., /* exponents into floating-point numbers. */ + 1.0e4, + 1.0e8, + 1.0e16, + 1.0e32, + 1.0e64, + 1.0e128, + 1.0e256 +}; + +/* + *---------------------------------------------------------------------- + * + * strtod -- + * + * This procedure converts a floating-point number from an ASCII + * decimal representation to internal double-precision format. + * + * Results: + * The return value is the double-precision floating-point + * representation of the characters in string. If endPtr isn't + * NULL, then *endPtr is filled in with the address of the + * next character after the last one that was part of the + * floating-point number. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +double +strtod(string, endPtr) + CONST char *string; /* A decimal ASCII floating-point number, + * optionally preceded by white space. + * Must have form "-I.FE-X", where I is the + * integer part of the mantissa, F is the + * fractional part of the mantissa, and X + * is the exponent. Either of the signs + * may be "+", "-", or omitted. Either I + * or F may be omitted, or both. The decimal + * point isn't necessary unless F is present. + * The "E" may actually be an "e". E and X + * may both be omitted (but not just one). + */ + char **endPtr; /* If non-NULL, store terminating character's + * address here. */ +{ + int sign, expSign = FALSE; + double fraction, dblExp, *d; + register CONST char *p; + register int c; + int exp = 0; /* Exponent read from "EX" field. */ + int fracExp = 0; /* Exponent that derives from the fractional + * part. Under normal circumstatnces, it is + * the negative of the number of digits in F. + * However, if I is very long, the last digits + * of I get dropped (otherwise a long I with a + * large negative exponent could cause an + * unnecessary overflow on I alone). In this + * case, fracExp is incremented one for each + * dropped digit. */ + int mantSize; /* Number of digits in mantissa. */ + int decPt; /* Number of mantissa digits BEFORE decimal + * point. */ + CONST char *pExp; /* Temporarily holds location of exponent + * in string. */ + + /* + * Strip off leading blanks and check for a sign. + */ + + p = string; + while (isspace(*p)) { + p += 1; + } + if (*p == '-') { + sign = TRUE; + p += 1; + } else { + if (*p == '+') { + p += 1; + } + sign = FALSE; + } + + /* + * Count the number of digits in the mantissa (including the decimal + * point), and also locate the decimal point. + */ + + decPt = -1; + for (mantSize = 0; ; mantSize += 1) + { + c = *p; + if (!isdigit(c)) { + if ((c != '.') || (decPt >= 0)) { + break; + } + decPt = mantSize; + } + p += 1; + } + + /* + * Now suck up the digits in the mantissa. Use two integers to + * collect 9 digits each (this is faster than using floating-point). + * If the mantissa has more than 18 digits, ignore the extras, since + * they can't affect the value anyway. + */ + + pExp = p; + p -= mantSize; + if (decPt < 0) { + decPt = mantSize; + } else { + mantSize -= 1; /* One of the digits was the point. */ + } + if (mantSize > 18) { + fracExp = decPt - 18; + mantSize = 18; + } else { + fracExp = decPt - mantSize; + } + if (mantSize == 0) { + fraction = 0.0; + p = string; + goto done; + } else { + int frac1, frac2; + frac1 = 0; + for ( ; mantSize > 9; mantSize -= 1) + { + c = *p; + p += 1; + if (c == '.') { + c = *p; + p += 1; + } + frac1 = 10*frac1 + (c - '0'); + } + frac2 = 0; + for (; mantSize > 0; mantSize -= 1) + { + c = *p; + p += 1; + if (c == '.') { + c = *p; + p += 1; + } + frac2 = 10*frac2 + (c - '0'); + } + fraction = (1.0e9 * frac1) + frac2; + } + + /* + * Skim off the exponent. + */ + + p = pExp; + if ((*p == 'E') || (*p == 'e')) { + p += 1; + if (*p == '-') { + expSign = TRUE; + p += 1; + } else { + if (*p == '+') { + p += 1; + } + expSign = FALSE; + } + while (isdigit(*p)) { + exp = exp * 10 + (*p - '0'); + p += 1; + } + } + if (expSign) { + exp = fracExp - exp; + } else { + exp = fracExp + exp; + } + + /* + * Generate a floating-point number that represents the exponent. + * Do this by processing the exponent one bit at a time to combine + * many powers of 2 of 10. Then combine the exponent with the + * fraction. + */ + + if (exp < 0) { + expSign = TRUE; + exp = -exp; + } else { + expSign = FALSE; + } + if (exp > maxExponent) { + exp = maxExponent; + } + dblExp = 1.0; + for (d = powersOf10; exp != 0; exp >>= 1, d += 1) { + if (exp & 01) { + dblExp *= *d; + } + } + if (expSign) { + fraction /= dblExp; + } else { + fraction *= dblExp; + } + +done: + if (endPtr != NULL) { + *endPtr = (char *) p; + } + + if (sign) { + return -fraction; + } + return fraction; +} diff --git a/vendor/x11iraf/obm/Tcl/compat/strtol.c b/vendor/x11iraf/obm/Tcl/compat/strtol.c new file mode 100644 index 00000000..b5341a78 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/compat/strtol.c @@ -0,0 +1,99 @@ +/* + * strtol.c -- + * + * Source code for the "strtol" library procedure. + * + * Copyright (c) 1988 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. + */ + +#ifndef lint +static char rcsid[] = "$Header: /user6/ouster/tcl/compat/RCS/strtol.c,v 1.2 93/03/19 15:25:43 ouster Exp $ SPRITE (Berkeley)"; +#endif /* not lint */ + +#include <ctype.h> + + +/* + *---------------------------------------------------------------------- + * + * strtol -- + * + * Convert an ASCII string into an integer. + * + * Results: + * The return value is the integer equivalent of string. If endPtr + * is non-NULL, then *endPtr is filled in with the character + * after the last one that was part of the integer. If string + * doesn't contain a valid integer value, then zero is returned + * and *endPtr is set to string. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +long int +strtol(string, endPtr, base) + char *string; /* String of ASCII digits, possibly + * preceded by white space. For bases + * greater than 10, either lower- or + * upper-case digits may be used. + */ + char **endPtr; /* Where to store address of terminating + * character, or NULL. */ + int base; /* Base for conversion. Must be less + * than 37. If 0, then the base is chosen + * from the leading characters of string: + * "0x" means hex, "0" means octal, anything + * else means decimal. + */ +{ + register char *p; + int result; + + /* + * Skip any leading blanks. + */ + + p = string; + while (isspace(*p)) { + p += 1; + } + + /* + * Check for a sign. + */ + + if (*p == '-') { + p += 1; + result = -(strtoul(p, endPtr, base)); + } else { + if (*p == '+') { + p += 1; + } + result = strtoul(p, endPtr, base); + } + if ((result == 0) && (endPtr != 0) && (*endPtr == p)) { + *endPtr = string; + } + return result; +} diff --git a/vendor/x11iraf/obm/Tcl/compat/strtoul.c b/vendor/x11iraf/obm/Tcl/compat/strtoul.c new file mode 100644 index 00000000..8981e2c8 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/compat/strtoul.c @@ -0,0 +1,199 @@ +/* + * strtoul.c -- + * + * Source code for the "strtoul" library procedure. + * + * Copyright (c) 1988 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. + */ + +#ifndef lint +static char rcsid[] = "$Header: /user6/ouster/tcl/compat/RCS/strtoul.c,v 1.3 93/03/19 15:25:41 ouster Exp $ SPRITE (Berkeley)"; +#endif /* not lint */ + +#include <ctype.h> + +/* + * The table below is used to convert from ASCII digits to a + * numerical equivalent. It maps from '0' through 'z' to integers + * (100 for non-digit characters). + */ + +static char cvtIn[] = { + 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, /* '0' - '9' */ + 100, 100, 100, 100, 100, 100, 100, /* punctuation */ + 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, /* 'A' - 'Z' */ + 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, + 30, 31, 32, 33, 34, 35, + 100, 100, 100, 100, 100, 100, /* punctuation */ + 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, /* 'a' - 'z' */ + 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, + 30, 31, 32, 33, 34, 35}; + +/* + *---------------------------------------------------------------------- + * + * strtoul -- + * + * Convert an ASCII string into an integer. + * + * Results: + * The return value is the integer equivalent of string. If endPtr + * is non-NULL, then *endPtr is filled in with the character + * after the last one that was part of the integer. If string + * doesn't contain a valid integer value, then zero is returned + * and *endPtr is set to string. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +unsigned long int +strtoul(string, endPtr, base) + char *string; /* String of ASCII digits, possibly + * preceded by white space. For bases + * greater than 10, either lower- or + * upper-case digits may be used. + */ + char **endPtr; /* Where to store address of terminating + * character, or NULL. */ + int base; /* Base for conversion. Must be less + * than 37. If 0, then the base is chosen + * from the leading characters of string: + * "0x" means hex, "0" means octal, anything + * else means decimal. + */ +{ + register char *p; + register unsigned long int result = 0; + register unsigned digit; + int anyDigits = 0; + + /* + * Skip any leading blanks. + */ + + p = string; + while (isspace(*p)) { + p += 1; + } + + /* + * If no base was provided, pick one from the leading characters + * of the string. + */ + + if (base == 0) + { + if (*p == '0') { + p += 1; + if (*p == 'x') { + p += 1; + base = 16; + } else { + + /* + * Must set anyDigits here, otherwise "0" produces a + * "no digits" error. + */ + + anyDigits = 1; + base = 8; + } + } + else base = 10; + } else if (base == 16) { + + /* + * Skip a leading "0x" from hex numbers. + */ + + if ((p[0] == '0') && (p[1] == 'x')) { + p += 2; + } + } + + /* + * Sorry this code is so messy, but speed seems important. Do + * different things for base 8, 10, 16, and other. + */ + + if (base == 8) { + for ( ; ; p += 1) { + digit = *p - '0'; + if (digit > 7) { + break; + } + result = (result << 3) + digit; + anyDigits = 1; + } + } else if (base == 10) { + for ( ; ; p += 1) { + digit = *p - '0'; + if (digit > 9) { + break; + } + result = (10*result) + digit; + anyDigits = 1; + } + } else if (base == 16) { + for ( ; ; p += 1) { + digit = *p - '0'; + if (digit > ('z' - '0')) { + break; + } + digit = cvtIn[digit]; + if (digit > 15) { + break; + } + result = (result << 4) + digit; + anyDigits = 1; + } + } else { + for ( ; ; p += 1) { + digit = *p - '0'; + if (digit > ('z' - '0')) { + break; + } + digit = cvtIn[digit]; + if (digit >= base) { + break; + } + result = result*base + digit; + anyDigits = 1; + } + } + + /* + * See if there were any digits at all. + */ + + if (!anyDigits) { + p = string; + } + + if (endPtr != 0) { + *endPtr = p; + } + + return result; +} diff --git a/vendor/x11iraf/obm/Tcl/compat/tmpnam.c b/vendor/x11iraf/obm/Tcl/compat/tmpnam.c new file mode 100644 index 00000000..48074716 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/compat/tmpnam.c @@ -0,0 +1,41 @@ +/* + * Copyright (c) 1988 Regents of the University of California. + * All rights reserved. + * + * Redistribution and use in source and binary forms are permitted + * provided that this notice is preserved and that due credit is given + * to the University of California at Berkeley. The name of the University + * may not be used to endorse or promote products derived from this + * software without specific written prior permission. This software + * is provided ``as is'' without express or implied warranty. + */ + +#if defined(LIBC_SCCS) && !defined(lint) +static char sccsid[] = "@(#)tmpnam.c 4.4 (Berkeley) 6/8/88"; +#endif /* LIBC_SCCS and not lint */ + +#include <sys/param.h> +#include <sys/stat.h> +#include <sys/file.h> +#include <stdio.h> + +/* + * Use /tmp instead of /usr/tmp, because L_tmpname is only 14 chars + * on some machines (like NeXT machines) and /usr/tmp will cause + * buffer overflows. + */ + +#define P_tmpdir "/tmp" + +char * +tmpnam(s) + char *s; +{ + static char name[50]; + char *mktemp(); + + if (!s) + s = name; + (void)sprintf(s, "%s/XXXXXX", P_tmpdir); + return(mktemp(s)); +} diff --git a/vendor/x11iraf/obm/Tcl/compat/unistd.h b/vendor/x11iraf/obm/Tcl/compat/unistd.h new file mode 100644 index 00000000..a0f31dca --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/compat/unistd.h @@ -0,0 +1,83 @@ +/* + * unistd.h -- + * + * Macros, CONSTants and prototypes for Posix conformance. + * + * Copyright 1989 Regents of the University of California + * 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. The University of California + * makes no representations about the suitability of this + * software for any purpose. It is provided "as is" without + * express or implied warranty. + * + * $Header: /user6/ouster/tcl/compat/RCS/unistd.h,v 1.4 93/09/02 16:35:38 ouster Exp $ + */ + +#ifndef _UNISTD +#define _UNISTD + +#include <sys/types.h> +#ifndef _TCL +# include "tcl.h" +#endif + +#ifndef NULL +#define NULL 0 +#endif + +/* + * Strict POSIX stuff goes here. Extensions go down below, in the + * ifndef _POSIX_SOURCE section. + */ + +extern void _exit _ANSI_ARGS_((int status)); +extern int access _ANSI_ARGS_((CONST char *path, int mode)); +extern int chdir _ANSI_ARGS_((CONST char *path)); +extern int chown _ANSI_ARGS_((CONST char *path, uid_t owner, gid_t group)); +extern int close _ANSI_ARGS_((int fd)); +extern int dup _ANSI_ARGS_((int oldfd)); +extern int dup2 _ANSI_ARGS_((int oldfd, int newfd)); +extern int execl _ANSI_ARGS_((CONST char *path, ...)); +extern int execle _ANSI_ARGS_((CONST char *path, ...)); +extern int execlp _ANSI_ARGS_((CONST char *file, ...)); +extern int execv _ANSI_ARGS_((CONST char *path, char **argv)); +extern int execve _ANSI_ARGS_((CONST char *path, char **argv, char **envp)); +extern int execvp _ANSI_ARGS_((CONST char *file, char **argv)); +extern pid_t fork _ANSI_ARGS_((void)); +extern char *getcwd _ANSI_ARGS_((char *buf, size_t size)); +extern gid_t getegid _ANSI_ARGS_((void)); +extern uid_t geteuid _ANSI_ARGS_((void)); +extern gid_t getgid _ANSI_ARGS_((void)); +extern int getgroups _ANSI_ARGS_((int bufSize, int *buffer)); +extern pid_t getpid _ANSI_ARGS_((void)); +extern uid_t getuid _ANSI_ARGS_((void)); +extern int isatty _ANSI_ARGS_((int fd)); +extern off_t lseek _ANSI_ARGS_((int fd, off_t offset, int whence)); +extern int pipe _ANSI_ARGS_((int *fildes)); +extern int read _ANSI_ARGS_((int fd, char *buf, size_t size)); +extern int setgid _ANSI_ARGS_((gid_t group)); +extern int setuid _ANSI_ARGS_((uid_t user)); +extern unsigned sleep _ANSI_ARGS_ ((unsigned seconds)); +extern char *ttyname _ANSI_ARGS_((int fd)); +extern int unlink _ANSI_ARGS_((CONST char *path)); +extern int write _ANSI_ARGS_((int fd, CONST char *buf, size_t size)); + +#ifndef _POSIX_SOURCE +extern char *crypt _ANSI_ARGS_((CONST char *, CONST char *)); +extern int fchown _ANSI_ARGS_((int fd, uid_t owner, gid_t group)); +extern int flock _ANSI_ARGS_((int fd, int operation)); +extern int ftruncate _ANSI_ARGS_((int fd, unsigned long length)); +extern int readlink _ANSI_ARGS_((CONST char *path, char *buf, int bufsize)); +extern int setegid _ANSI_ARGS_((gid_t group)); +extern int seteuid _ANSI_ARGS_((uid_t user)); +extern int setreuid _ANSI_ARGS_((int ruid, int euid)); +extern int symlink _ANSI_ARGS_((CONST char *, CONST char *)); +extern int ttyslot _ANSI_ARGS_((void)); +extern int truncate _ANSI_ARGS_((CONST char *path, unsigned long length)); +extern int vfork _ANSI_ARGS_((void)); +#endif /* _POSIX_SOURCE */ + +#endif /* _UNISTD */ + diff --git a/vendor/x11iraf/obm/Tcl/compat/waitpid.c b/vendor/x11iraf/obm/Tcl/compat/waitpid.c new file mode 100644 index 00000000..dd9713fa --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/compat/waitpid.c @@ -0,0 +1,186 @@ +/* + * waitpid.c -- + * + * This procedure emulates the POSIX waitpid kernel call on + * BSD systems that don't have waitpid but do have wait3. + * This code is based on a prototype version written by + * Mark Diekhans and Karl Lehenbauer. + * + * Copyright (c) 1993 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. + */ + +#ifndef lint +static char rcsid[] = "$Header: /user6/ouster/tcl/compat/RCS/waitpid.c,v 1.5 93/07/01 15:25:18 ouster Exp $ SPRITE (Berkeley)"; +#endif /* not lint */ + +#include "tclInt.h" +#include "tclUnix.h" + +/* + * A linked list of the following structures is used to keep track + * of processes for which we received notification from the kernel, + * but the application hasn't waited for them yet (this can happen + * because wait may not return the process we really want). We + * save the information here until the application finally does + * wait for the process. + */ + +typedef struct WaitInfo { + int pid; /* Pid of process that exited. */ + WAIT_STATUS_TYPE status; /* Status returned when child exited + * or suspended. */ + struct WaitInfo *nextPtr; /* Next in list of exited processes. */ +} WaitInfo; + +static WaitInfo *deadList = NULL; /* First in list of all dead + * processes. */ + +/* + *---------------------------------------------------------------------- + * + * waitpid -- + * + * This procedure emulates the functionality of the POSIX + * waitpid kernel call, using the BSD wait3 kernel call. + * Note: it doesn't emulate absolutely all of the waitpid + * functionality, in that it doesn't support pid's of 0 + * or < -1. + * + * Results: + * -1 is returned if there is an error in the wait kernel call. + * Otherwise the pid of an exited or suspended process is + * returned and *statusPtr is set to the status value of the + * process. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +#ifdef waitpid +# undef waitpid +#endif + +int +waitpid(pid, statusPtr, options) + int pid; /* The pid to wait on. Must be -1 or + * greater than zero. */ + int *statusPtr; /* Where to store wait status for the + * process. */ + int options; /* OR'ed combination of WNOHANG and + * WUNTRACED. */ +{ + register WaitInfo *waitPtr, *prevPtr; + int result; + WAIT_STATUS_TYPE status; + + if ((pid < -1) || (pid == 0)) { + errno = EINVAL; + return -1; + } + + /* + * See if there's a suitable process that has already stopped or + * exited. If so, remove it from the list of exited processes and + * return its information. + */ + + for (waitPtr = deadList, prevPtr = NULL; waitPtr != NULL; + prevPtr = waitPtr, waitPtr = waitPtr->nextPtr) { + if ((pid != waitPtr->pid) && (pid != -1)) { + continue; + } + if (!(options & WUNTRACED) && (WIFSTOPPED(waitPtr->status))) { + continue; + } + result = waitPtr->pid; + *statusPtr = *((int *) &waitPtr->status); + if (prevPtr == NULL) { + deadList = waitPtr->nextPtr; + } else { + prevPtr->nextPtr = waitPtr->nextPtr; + } + ckfree((char *) waitPtr); + return result; + } + + /* + * Wait for any process to stop or exit. If it's an acceptable one + * then return it to the caller; otherwise store information about it + * in the list of exited processes and try again. On systems that + * have only wait but not wait3, there are several situations we can't + * handle, but we do the best we can (e.g. can still handle some + * combinations of options by invoking wait instead of wait3). + */ + + while (1) { +#if NO_WAIT3 + if (options & WNOHANG) { + return 0; + } + if (options != 0) { + errno = EINVAL; + return -1; + } + result = wait(&status); +#else + result = wait3(&status, options, 0); +#endif + if ((result == -1) && (errno == EINTR)) { + continue; + } + if (result <= 0) { + return result; + } + + if ((pid != result) && (pid != -1)) { + goto saveInfo; + } + if (!(options & WUNTRACED) && (WIFSTOPPED(status))) { + goto saveInfo; + } + *statusPtr = *((int *) &status); + return result; + + /* + * Can't return this info to caller. Save it in the list of + * stopped or exited processes. Tricky point: first check for + * an existing entry for the process and overwrite it if it + * exists (e.g. a previously stopped process might now be dead). + */ + + saveInfo: + for (waitPtr = deadList; waitPtr != NULL; waitPtr = waitPtr->nextPtr) { + if (waitPtr->pid == result) { + waitPtr->status = status; + goto waitAgain; + } + } + waitPtr = (WaitInfo *) ckalloc(sizeof(WaitInfo)); + waitPtr->pid = result; + waitPtr->status = status; + waitPtr->nextPtr = deadList; + deadList = waitPtr; + + waitAgain: continue; + } +} diff --git a/vendor/x11iraf/obm/Tcl/config.status b/vendor/x11iraf/obm/Tcl/config.status new file mode 100755 index 00000000..d53efe58 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/config.status @@ -0,0 +1,64 @@ +#!/bin/sh +# Generated automatically by configure. +# Run this file to recreate the current configuration. +# This directory was configured as follows, +# on host apus: +# +# ./configure + +for arg +do + case "$arg" in + -recheck | --recheck | --rechec | --reche | --rech | --rec | --re | --r) + exec /bin/sh ./configure ;; + *) echo "Usage: config.status --recheck" 2>&1; exit 1 ;; + esac +done + +trap 'rm -f Makefile; exit 1' 1 3 15 +INSTALL='cp' +INSTALL_PROGRAM='$(INSTALL)' +INSTALL_DATA='$(INSTALL)' +RANLIB='echo ranlib' +CC='cc' +LIBOBJS=' tclMtherr.o' +CPP='cc -E' +LIBS='' +srcdir='.' +DEFS=' -DNO_GETWD=1 -DNO_WAIT3=1 -DHAVE_UNISTD_H=1 -DNO_UNION_WAIT=1 -DNEED_MATHERR=1' +prefix='' +exec_prefix='' +prsub='' + +top_srcdir=$srcdir + +# Allow make-time overrides of the generated file list. +test -n "$gen_files" || gen_files="Makefile" + +for file in .. $gen_files; do if [ "x$file" != "x.." ]; then + srcdir=$top_srcdir + # Remove last slash and all that follows it. Not all systems have dirname. + dir=`echo $file|sed 's%/[^/][^/]*$%%'` + if test "$dir" != "$file"; then + test "$top_srcdir" != . && srcdir=$top_srcdir/$dir + test ! -d $dir && mkdir $dir + fi + echo creating $file + rm -f $file + echo "# Generated automatically from `echo $file|sed 's|.*/||'`.in by configure." > $file + sed -e " +$prsub +s%@INSTALL@%$INSTALL%g +s%@INSTALL_PROGRAM@%$INSTALL_PROGRAM%g +s%@INSTALL_DATA@%$INSTALL_DATA%g +s%@RANLIB@%$RANLIB%g +s%@CC@%$CC%g +s%@LIBOBJS@%$LIBOBJS%g +s%@CPP@%$CPP%g +s%@LIBS@%$LIBS%g +s%@srcdir@%$srcdir%g +s%@DEFS@%$DEFS% +" $top_srcdir/${file}.in >> $file +fi; done + +exit 0 diff --git a/vendor/x11iraf/obm/Tcl/configure b/vendor/x11iraf/obm/Tcl/configure new file mode 100755 index 00000000..61f0a4d3 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/configure @@ -0,0 +1,1015 @@ +#!/bin/sh +# Guess values for system-dependent variables and create Makefiles. +# Generated automatically using autoconf. +# Copyright (C) 1991, 1992, 1993 Free Software Foundation, Inc. + +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2, or (at your option) +# any later version. + +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. + +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +# Usage: configure [--srcdir=DIR] [--host=HOST] [--gas] [--nfp] [--no-create] +# [--prefix=PREFIX] [--exec-prefix=PREFIX] [--with-PACKAGE] [TARGET] +# Ignores all args except --srcdir, --prefix, --exec-prefix, --no-create, and +# --with-PACKAGE unless this script has special code to handle it. + + +for arg +do + # Handle --exec-prefix with a space before the argument. + if test x$next_exec_prefix = xyes; then exec_prefix=$arg; next_exec_prefix= + # Handle --host with a space before the argument. + elif test x$next_host = xyes; then next_host= + # Handle --prefix with a space before the argument. + elif test x$next_prefix = xyes; then prefix=$arg; next_prefix= + # Handle --srcdir with a space before the argument. + elif test x$next_srcdir = xyes; then srcdir=$arg; next_srcdir= + else + case $arg in + # For backward compatibility, also recognize exact --exec_prefix. + -exec-prefix=* | --exec_prefix=* | --exec-prefix=* | --exec-prefi=* | --exec-pref=* | --exec-pre=* | --exec-pr=* | --exec-p=* | --exec-=* | --exec=* | --exe=* | --ex=* | --e=*) + exec_prefix=`echo $arg | sed 's/[-a-z_]*=//'` ;; + -exec-prefix | --exec_prefix | --exec-prefix | --exec-prefi | --exec-pref | --exec-pre | --exec-pr | --exec-p | --exec- | --exec | --exe | --ex | --e) + next_exec_prefix=yes ;; + + -gas | --gas | --ga | --g) ;; + + -host=* | --host=* | --hos=* | --ho=* | --h=*) ;; + -host | --host | --hos | --ho | --h) + next_host=yes ;; + + -nfp | --nfp | --nf) ;; + + -no-create | --no-create | --no-creat | --no-crea | --no-cre | --no-cr | --no-c | --no- | --no) + no_create=1 ;; + + -prefix=* | --prefix=* | --prefi=* | --pref=* | --pre=* | --pr=* | --p=*) + prefix=`echo $arg | sed 's/[-a-z_]*=//'` ;; + -prefix | --prefix | --prefi | --pref | --pre | --pr | --p) + next_prefix=yes ;; + + -srcdir=* | --srcdir=* | --srcdi=* | --srcd=* | --src=* | --sr=* | --s=*) + srcdir=`echo $arg | sed 's/[-a-z_]*=//'` ;; + -srcdir | --srcdir | --srcdi | --srcd | --src | --sr | --s) + next_srcdir=yes ;; + + -with-* | --with-*) + package=`echo $arg|sed 's/-*with-//'` + # Delete all the valid chars; see if any are left. + if test -n "`echo $package|sed 's/[-a-zA-Z0-9_]*//g'`"; then + echo "configure: $package: invalid package name" >&2; exit 1 + fi + eval "with_`echo $package|sed s/-/_/g`=1" ;; + + -v | -verbose | --verbose | --verbos | --verbo | --verb | --ver | --ve | --v) + verbose=yes ;; + + *) ;; + esac + fi +done + +trap 'rm -fr conftest* core; exit 1' 1 3 15 + +# NLS nuisances. +# These must not be set unconditionally because not all systems understand +# e.g. LANG=C (notably SCO). +if test "${LC_ALL+set}" = 'set' ; then LC_ALL=C; export LC_ALL; fi +if test "${LANG+set}" = 'set' ; then LANG=C; export LANG; fi + +rm -f conftest* +compile='${CC-cc} $CFLAGS $DEFS conftest.c -o conftest $LIBS >/dev/null 2>&1' + +# A filename unique to this package, relative to the directory that +# configure is in, which we can look for to find out if srcdir is correct. +unique_file=tcl.h + +# Find the source files, if location was not specified. +if test -z "$srcdir"; then + srcdirdefaulted=yes + # Try the directory containing this script, then `..'. + prog=$0 + confdir=`echo $prog|sed 's%/[^/][^/]*$%%'` + test "X$confdir" = "X$prog" && confdir=. + srcdir=$confdir + if test ! -r $srcdir/$unique_file; then + srcdir=.. + fi +fi +if test ! -r $srcdir/$unique_file; then + if test x$srcdirdefaulted = xyes; then + echo "configure: Can not find sources in \`${confdir}' or \`..'." 1>&2 + else + echo "configure: Can not find sources in \`${srcdir}'." 1>&2 + fi + exit 1 +fi +# Preserve a srcdir of `.' to avoid automounter screwups with pwd. +# But we can't avoid them for `..', to make subdirectories work. +case $srcdir in + .|/*|~*) ;; + *) srcdir=`cd $srcdir; pwd` ;; # Make relative path absolute. +esac + +# Save the original args to write them into config.status later. +configure_args="$*" + +# Make sure to not get the incompatible SysV /etc/install and +# /usr/sbin/install, which might be in PATH before a BSD-like install, +# or the SunOS /usr/etc/install directory, or the AIX /bin/install, +# or the AFS install, which mishandles nonexistent args, or +# /usr/ucb/install on SVR4, which tries to use the nonexistent group +# `staff'. On most BSDish systems install is in /usr/bin, not /usr/ucb +# anyway. Sigh. +if test "z${INSTALL}" = "z" ; then + echo checking for install + IFS="${IFS= }"; saveifs="$IFS"; IFS="${IFS}:" + for dir in $PATH; do + test -z "$dir" && dir=. + case $dir in + /etc|/usr/sbin|/usr/etc|/usr/afsws/bin|/usr/ucb) ;; + *) + if test -f $dir/installbsd; then + INSTALL="$dir/installbsd -c" # OSF1 + INSTALL_PROGRAM='$(INSTALL)' + INSTALL_DATA='$(INSTALL) -m 644' + break + fi + if test -f $dir/install; then + if grep dspmsg $dir/install >/dev/null 2>&1; then + : # AIX + else + INSTALL="$dir/install -c" + INSTALL_PROGRAM='$(INSTALL)' + INSTALL_DATA='$(INSTALL) -m 644' + break + fi + fi + ;; + esac + done + IFS="$saveifs" +fi +INSTALL=${INSTALL-cp} +INSTALL_PROGRAM=${INSTALL_PROGRAM-'$(INSTALL)'} +INSTALL_DATA=${INSTALL_DATA-'$(INSTALL)'} + +if test -z "$RANLIB"; then + # Extract the first word of `ranlib', so it can be a program name with args. + set dummy ranlib; word=$2 + echo checking for $word + IFS="${IFS= }"; saveifs="$IFS"; IFS="${IFS}:" + for dir in $PATH; do + test -z "$dir" && dir=. + if test -f $dir/$word; then + RANLIB="ranlib" + break + fi + done + IFS="$saveifs" +fi +test -z "$RANLIB" && RANLIB=":" +test -n "$RANLIB" -a -n "$verbose" && echo " setting RANLIB to $RANLIB" + +CC=${CC-cc} + + +#-------------------------------------------------------------------- +# Supply substitutes for missing POSIX library procedures, or +# set flags so Tcl uses alternate procedures. +#-------------------------------------------------------------------- + +for func in getcwd opendir strerror strstr +do +echo checking for ${func} +cat > conftest.c <<EOF +#include <ctype.h> +int main() { exit(0); } +int t() { +/* 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_${func}) || defined (__stub___${func}) +choke me +#else +/* Override any gcc2 internal prototype to avoid an error. */ +extern char ${func}(); ${func}(); +#endif + } +EOF +if eval $compile; then + : +else + LIBOBJS="$LIBOBJS ${func}.o" +test -n "$verbose" && echo " using ${func}.o instead" +fi +rm -f conftest* + +done + +for func in strtol tmpnam waitpid +do +echo checking for ${func} +cat > conftest.c <<EOF +#include <ctype.h> +int main() { exit(0); } +int t() { +/* 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_${func}) || defined (__stub___${func}) +choke me +#else +/* Override any gcc2 internal prototype to avoid an error. */ +extern char ${func}(); ${func}(); +#endif + } +EOF +if eval $compile; then + : +else + LIBOBJS="$LIBOBJS ${func}.o" +test -n "$verbose" && echo " using ${func}.o instead" +fi +rm -f conftest* + +done + +echo checking for gettimeofday +cat > conftest.c <<EOF +#include <ctype.h> +int main() { exit(0); } +int t() { +/* 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_gettimeofday) || defined (__stub___gettimeofday) +choke me +#else +/* Override any gcc2 internal prototype to avoid an error. */ +extern char gettimeofday(); gettimeofday(); +#endif + } +EOF +if eval $compile; then + : +else + { +test -n "$verbose" && \ +echo " defining NO_GETTOD" +DEFS="$DEFS -DNO_GETTOD=1" +} + +fi +rm -f conftest* + +echo checking for getwd +cat > conftest.c <<EOF +#include <ctype.h> +int main() { exit(0); } +int t() { +/* 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_getwd) || defined (__stub___getwd) +choke me +#else +/* Override any gcc2 internal prototype to avoid an error. */ +extern char getwd(); getwd(); +#endif + } +EOF +if eval $compile; then + : +else + { +test -n "$verbose" && \ +echo " defining NO_GETWD" +DEFS="$DEFS -DNO_GETWD=1" +} + +fi +rm -f conftest* + +echo checking for wait3 +cat > conftest.c <<EOF +#include <ctype.h> +int main() { exit(0); } +int t() { +/* 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_wait3) || defined (__stub___wait3) +choke me +#else +/* Override any gcc2 internal prototype to avoid an error. */ +extern char wait3(); wait3(); +#endif + } +EOF +if eval $compile; then + : +else + { +test -n "$verbose" && \ +echo " defining NO_WAIT3" +DEFS="$DEFS -DNO_WAIT3=1" +} + +fi +rm -f conftest* + + +#-------------------------------------------------------------------- +# Supply substitutes for missing POSIX header files. Special +# notes: +# - Sprite's dirent.h exists but is bogus. +# - 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 +#-------------------------------------------------------------------- + +echo checking for unistd.h +echo checking how to run the C preprocessor +if test -z "$CPP"; then + # This must be in double quotes, not single quotes, because CPP may get + # substituted into the Makefile and ``${CC-cc}'' will simply confuse + # make. It must be expanded now. + CPP="${CC-cc} -E" + cat > conftest.c <<EOF +#include <stdio.h> +Syntax Error +EOF +err=`eval "($CPP \$DEFS conftest.c >/dev/null) 2>&1"` +if test -z "$err"; then + : +else + CPP=/lib/cpp +fi +rm -f conftest* +fi +test ".${verbose}" != "." && echo " setting CPP to $CPP" + +cat > conftest.c <<EOF +#include <unistd.h> +EOF +err=`eval "($CPP \$DEFS conftest.c >/dev/null) 2>&1"` +if test -z "$err"; then + +{ +test -n "$verbose" && \ +echo " defining HAVE_UNISTD_H" +DEFS="$DEFS -DHAVE_UNISTD_H=1" +} + +fi +rm -f conftest* + +echo checking for dirent.h +cat > conftest.c <<EOF +#include <sys/types.h> +#include <dirent.h> +int main() { exit(0); } +int t() { +DIR *d; +struct dirent *entryPtr; +char *p; +d = opendir("foobar"); +entryPtr = readdir(d); +p = entryPtr->d_name; +closedir(d); + } +EOF +if eval $compile; then + tcl_ok=1 +else + tcl_ok=0 +fi +rm -f conftest* + +echo '#include <tcl_ok=0>' > conftest.c +eval "$CPP \$DEFS conftest.c > conftest.out 2>&1" +if egrep "Sprite version.* NOT POSIX" conftest.out >/dev/null 2>&1; then + : +fi +rm -f conftest* + +if test $tcl_ok = 0; then + +{ +test -n "$verbose" && \ +echo " defining NO_DIRENT_H" +DEFS="$DEFS -DNO_DIRENT_H=1" +} + +fi +echo checking for errno.h +cat > conftest.c <<EOF +#include <errno.h> +EOF +err=`eval "($CPP \$DEFS conftest.c >/dev/null) 2>&1"` +if test -z "$err"; then + : +else + +{ +test -n "$verbose" && \ +echo " defining NO_ERRNO_H" +DEFS="$DEFS -DNO_ERRNO_H=1" +} + +fi +rm -f conftest* + +echo checking for float.h +cat > conftest.c <<EOF +#include <float.h> +EOF +err=`eval "($CPP \$DEFS conftest.c >/dev/null) 2>&1"` +if test -z "$err"; then + : +else + +{ +test -n "$verbose" && \ +echo " defining NO_FLOAT_H" +DEFS="$DEFS -DNO_FLOAT_H=1" +} + +fi +rm -f conftest* + +echo checking for limits.h +cat > conftest.c <<EOF +#include <limits.h> +EOF +err=`eval "($CPP \$DEFS conftest.c >/dev/null) 2>&1"` +if test -z "$err"; then + : +else + +{ +test -n "$verbose" && \ +echo " defining NO_LIMITS_H" +DEFS="$DEFS -DNO_LIMITS_H=1" +} + +fi +rm -f conftest* + +echo checking for stdlib.h +cat > conftest.c <<EOF +#include <stdlib.h> +EOF +err=`eval "($CPP \$DEFS conftest.c >/dev/null) 2>&1"` +if test -z "$err"; then + tcl_ok=1 +else + tcl_ok=0 +fi +rm -f conftest* + +echo '#include <stdlib.h>' > conftest.c +eval "$CPP \$DEFS conftest.c > conftest.out 2>&1" +if egrep "strtol" conftest.out >/dev/null 2>&1; then + : +else + tcl_ok=0 +fi +rm -f conftest* + +echo '#include <stdlib.h>' > conftest.c +eval "$CPP \$DEFS conftest.c > conftest.out 2>&1" +if egrep "strtoul" conftest.out >/dev/null 2>&1; then + : +else + tcl_ok=0 +fi +rm -f conftest* + +echo '#include <stdlib.h>' > conftest.c +eval "$CPP \$DEFS conftest.c > conftest.out 2>&1" +if egrep "strtod" conftest.out >/dev/null 2>&1; then + : +else + tcl_ok=0 +fi +rm -f conftest* + +if test $tcl_ok = 0; then + +{ +test -n "$verbose" && \ +echo " defining NO_STDLIB_H" +DEFS="$DEFS -DNO_STDLIB_H=1" +} + +fi +echo checking for string.h +cat > conftest.c <<EOF +#include <string.h> +EOF +err=`eval "($CPP \$DEFS conftest.c >/dev/null) 2>&1"` +if test -z "$err"; then + tcl_ok=1 +else + tcl_ok=0 +fi +rm -f conftest* + +echo '#include <string.h>' > conftest.c +eval "$CPP \$DEFS conftest.c > conftest.out 2>&1" +if egrep "strstr" conftest.out >/dev/null 2>&1; then + : +else + tcl_ok=0 +fi +rm -f conftest* + +echo '#include <string.h>' > conftest.c +eval "$CPP \$DEFS conftest.c > conftest.out 2>&1" +if egrep "strerror" conftest.out >/dev/null 2>&1; then + : +else + tcl_ok=0 +fi +rm -f conftest* + +if test $tcl_ok = 0; then + +{ +test -n "$verbose" && \ +echo " defining NO_STRING_H" +DEFS="$DEFS -DNO_STRING_H=1" +} + +fi +echo checking for sys/time.h +cat > conftest.c <<EOF +#include <sys/time.h> +EOF +err=`eval "($CPP \$DEFS conftest.c >/dev/null) 2>&1"` +if test -z "$err"; then + : +else + +{ +test -n "$verbose" && \ +echo " defining NO_SYS_TIME_H" +DEFS="$DEFS -DNO_SYS_TIME_H=1" +} + +fi +rm -f conftest* + +echo checking for sys/wait.h +cat > conftest.c <<EOF +#include <sys/wait.h> +EOF +err=`eval "($CPP \$DEFS conftest.c >/dev/null) 2>&1"` +if test -z "$err"; then + : +else + +{ +test -n "$verbose" && \ +echo " defining NO_SYS_WAIT_H" +DEFS="$DEFS -DNO_SYS_WAIT_H=1" +} + +fi +rm -f conftest* + + +#-------------------------------------------------------------------- +# On some systems strstr is broken: it returns a pointer even +# even if the original string is empty. +#-------------------------------------------------------------------- + +cat > conftest.c <<EOF + +extern int strstr(); +int main() +{ + exit(strstr("\0test", "test") ? 1 : 0); +} + +EOF +eval $compile +if test -s conftest && (./conftest; exit) 2>/dev/null; then + : +else + LIBOBJS="$LIBOBJS strstr.o" +fi +rm -f conftest* + +#-------------------------------------------------------------------- +# Check for strtoul function. This is tricky because under some +# versions of AIX strtoul returns an incorrect terminator +# pointer for the string "0". +#-------------------------------------------------------------------- + +echo checking for strtoul +cat > conftest.c <<EOF +#include <ctype.h> +int main() { exit(0); } +int t() { +/* 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_strtoul) || defined (__stub___strtoul) +choke me +#else +/* Override any gcc2 internal prototype to avoid an error. */ +extern char strtoul(); strtoul(); +#endif + } +EOF +if eval $compile; then + tcl_ok=1 +else + tcl_ok=0 +fi +rm -f conftest* + +cat > conftest.c <<EOF + +extern int strtoul(); +int main() +{ + char *string = "0"; + char *term; + int value; + value = strtoul(string, &term, 0); + if ((value != 0) || (term != (string+1))) { + exit(1); + } + exit(0); +} +EOF +eval $compile +if test -s conftest && (./conftest; exit) 2>/dev/null; then + : +else + tcl_ok=0 +fi +rm -f conftest* +if test $tcl_ok = 0; then + LIBOBJS="$LIBOBJS strtoul.o" +fi + +#-------------------------------------------------------------------- +# Check for the strtod function. This is tricky because under +# some versions of Linux it mis-parses the string "+". +#-------------------------------------------------------------------- + +echo checking for strtod +cat > conftest.c <<EOF +#include <ctype.h> +int main() { exit(0); } +int t() { +/* 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_strtod) || defined (__stub___strtod) +choke me +#else +/* Override any gcc2 internal prototype to avoid an error. */ +extern char strtod(); strtod(); +#endif + } +EOF +if eval $compile; then + tcl_ok=1 +else + tcl_ok=0 +fi +rm -f conftest* + +cat > conftest.c <<EOF + +extern double strtod(); +int main() +{ + char *string = "+"; + char *term; + double value; + value = strtod(string, &term); + if (term != string) { + exit(1); + } + exit(0); +} +EOF +eval $compile +if test -s conftest && (./conftest; exit) 2>/dev/null; then + : +else + tcl_ok=0 +fi +rm -f conftest* +if test $tcl_ok = 0; then + LIBOBJS="$LIBOBJS strtod.o" +fi + +#-------------------------------------------------------------------- +# Check for various typedefs and provide substitutes if +# they don't exist. +#-------------------------------------------------------------------- + +echo checking for mode_t in sys/types.h +echo '#include <sys/types.h>' > conftest.c +eval "$CPP \$DEFS conftest.c > conftest.out 2>&1" +if egrep "mode_t" conftest.out >/dev/null 2>&1; then + : +else + +{ +test -n "$verbose" && \ +echo " defining mode_t to be int" +DEFS="$DEFS -Dmode_t=int" +} + +fi +rm -f conftest* + +echo checking for pid_t in sys/types.h +echo '#include <sys/types.h>' > conftest.c +eval "$CPP \$DEFS conftest.c > conftest.out 2>&1" +if egrep "pid_t" conftest.out >/dev/null 2>&1; then + : +else + +{ +test -n "$verbose" && \ +echo " defining pid_t to be int" +DEFS="$DEFS -Dpid_t=int" +} + +fi +rm -f conftest* + +echo checking for size_t in sys/types.h +echo '#include <sys/types.h>' > conftest.c +eval "$CPP \$DEFS conftest.c > conftest.out 2>&1" +if egrep "size_t" conftest.out >/dev/null 2>&1; then + : +else + +{ +test -n "$verbose" && \ +echo " defining size_t to be unsigned" +DEFS="$DEFS -Dsize_t=unsigned" +} + +fi +rm -f conftest* + +echo checking for uid_t in sys/types.h +echo '#include <sys/types.h>' > conftest.c +eval "$CPP \$DEFS conftest.c > conftest.out 2>&1" +if egrep "uid_t" conftest.out >/dev/null 2>&1; then + : +else + +{ +test -n "$verbose" && \ +echo " defining uid_t to be int" +DEFS="$DEFS -Duid_t=int" +} + +{ +test -n "$verbose" && \ +echo " defining gid_t to be int" +DEFS="$DEFS -Dgid_t=int" +} + +fi +rm -f conftest* + + +#-------------------------------------------------------------------- +# If a system doesn't have an opendir function (man, that's old!) +# then we have to supply a different version of dirent.h which +# is compatible with the substitute version of opendir that's +# provided. This version only works with V7-style directories. +#-------------------------------------------------------------------- + +echo checking for opendir +cat > conftest.c <<EOF +#include <ctype.h> +int main() { exit(0); } +int t() { +/* 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_opendir) || defined (__stub___opendir) +choke me +#else +/* Override any gcc2 internal prototype to avoid an error. */ +extern char opendir(); opendir(); +#endif + } +EOF +if eval $compile; then + : +else + { +test -n "$verbose" && \ +echo " defining USE_DIRENT2_H" +DEFS="$DEFS -DUSE_DIRENT2_H=1" +} + +fi +rm -f conftest* + + +#-------------------------------------------------------------------- +# Check for the existence of sys_errlist (this is only needed if +# there's no strerror, but I don't know how to conditionalize the +# check). +#-------------------------------------------------------------------- + +echo checking for sys_errlist +cat > conftest.c <<EOF + +int main() { exit(0); } +int t() { +extern char *sys_errlist[]; +extern int sys_nerr; +sys_errlist[sys_nerr-1][0] = 0; + } +EOF +if eval $compile; then + : +else + +{ +test -n "$verbose" && \ +echo " defining NO_SYS_ERRLIST" +DEFS="$DEFS -DNO_SYS_ERRLIST=1" +} + +fi +rm -f conftest* + + +#-------------------------------------------------------------------- +# The check below checks whether <sys/wait.h> defines the type +# "union wait" correctly. It's needed because of weirdness in +# HP-UX where "union wait" is defined in both the BSD and SYS-V +# environments. Checking the usability of WIFEXITED seems to do +# the trick. +#-------------------------------------------------------------------- + +echo checking for union wait +cat > conftest.c <<EOF +#include <sys/types.h> +#include <sys/wait.h> +int main() { exit(0); } +int t() { +union wait x; +WIFEXITED(x); /* Generates compiler error if WIFEXITED + * uses an int. */ + } +EOF +if eval $compile; then + : +else + +{ +test -n "$verbose" && \ +echo " defining NO_UNION_WAIT" +DEFS="$DEFS -DNO_UNION_WAIT=1" +} + +fi +rm -f conftest* + + +#-------------------------------------------------------------------- +# Check to see whether the system supports the matherr function +# and its associated type "struct exception". +#-------------------------------------------------------------------- + +echo checking for matherr support +cat > conftest.c <<EOF +#include <math.h> +int main() { exit(0); } +int t() { +struct exception x; +x.type = DOMAIN; +x.type = SING; + } +EOF +if eval $compile; then + LIBOBJS="$LIBOBJS tclMtherr.o"; +{ +test -n "$verbose" && \ +echo " defining NEED_MATHERR" +DEFS="$DEFS -DNEED_MATHERR=1" +} + +fi +rm -f conftest* + + +if test -n "$prefix"; then + test -z "$exec_prefix" && exec_prefix='${prefix}' + prsub="s%^prefix\\([ ]*\\)=\\([ ]*\\).*$%prefix\\1=\\2$prefix%" +fi +if test -n "$exec_prefix"; then + prsub="$prsub +s%^exec_prefix\\([ ]*\\)=\\([ ]*\\).*$%exec_prefix\\1=\\2$exec_prefix%" +fi +cat >conftest.def <<EOF +$DEFS +EOF +escape_ampersand_and_backslash='s%[&\\]%\\&%g' +DEFS=`sed "$escape_ampersand_and_backslash" <conftest.def` +rm -f conftest.def + +trap 'rm -f config.status; exit 1' 1 3 15 +echo creating config.status +rm -f config.status +cat > config.status <<EOF +#!/bin/sh +# Generated automatically by configure. +# Run this file to recreate the current configuration. +# This directory was configured as follows, +# on host `(hostname || uname -n) 2>/dev/null | sed 1q`: +# +# $0 $configure_args + +for arg +do + case "\$arg" in + -recheck | --recheck | --rechec | --reche | --rech | --rec | --re | --r) + exec /bin/sh $0 $configure_args ;; + *) echo "Usage: config.status --recheck" 2>&1; exit 1 ;; + esac +done + +trap 'rm -f Makefile; exit 1' 1 3 15 +INSTALL='$INSTALL' +INSTALL_PROGRAM='$INSTALL_PROGRAM' +INSTALL_DATA='$INSTALL_DATA' +RANLIB='$RANLIB' +CC='$CC' +LIBOBJS='$LIBOBJS' +CPP='$CPP' +LIBS='$LIBS' +srcdir='$srcdir' +DEFS='$DEFS' +prefix='$prefix' +exec_prefix='$exec_prefix' +prsub='$prsub' +EOF +cat >> config.status <<\EOF + +top_srcdir=$srcdir + +# Allow make-time overrides of the generated file list. +test -n "$gen_files" || gen_files="Makefile" + +for file in .. $gen_files; do if [ "x$file" != "x.." ]; then + srcdir=$top_srcdir + # Remove last slash and all that follows it. Not all systems have dirname. + dir=`echo $file|sed 's%/[^/][^/]*$%%'` + if test "$dir" != "$file"; then + test "$top_srcdir" != . && srcdir=$top_srcdir/$dir + test ! -d $dir && mkdir $dir + fi + echo creating $file + rm -f $file + echo "# Generated automatically from `echo $file|sed 's|.*/||'`.in by configure." > $file + sed -e " +$prsub +s%@INSTALL@%$INSTALL%g +s%@INSTALL_PROGRAM@%$INSTALL_PROGRAM%g +s%@INSTALL_DATA@%$INSTALL_DATA%g +s%@RANLIB@%$RANLIB%g +s%@CC@%$CC%g +s%@LIBOBJS@%$LIBOBJS%g +s%@CPP@%$CPP%g +s%@LIBS@%$LIBS%g +s%@srcdir@%$srcdir%g +s%@DEFS@%$DEFS% +" $top_srcdir/${file}.in >> $file +fi; done + +exit 0 +EOF +chmod +x config.status +test -n "$no_create" || ./config.status + diff --git a/vendor/x11iraf/obm/Tcl/configure.in b/vendor/x11iraf/obm/Tcl/configure.in new file mode 100755 index 00000000..f1fa256c --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/configure.in @@ -0,0 +1,182 @@ +dnl This file is an input file used by the GNU "autoconf" program to +dnl generate the file "configure", which is run during Tcl installation +dnl to configure the system for the local environment. +AC_INIT(tcl.h) +AC_PROG_INSTALL +AC_PROG_RANLIB +CC=${CC-cc} +AC_SUBST(CC) + +#-------------------------------------------------------------------- +# Supply substitutes for missing POSIX library procedures, or +# set flags so Tcl uses alternate procedures. +#-------------------------------------------------------------------- + +AC_REPLACE_FUNCS(getcwd opendir strerror strstr) +AC_REPLACE_FUNCS(strtol tmpnam waitpid) +AC_FUNC_CHECK(gettimeofday, , AC_DEFINE(NO_GETTOD)) +AC_FUNC_CHECK(getwd, , AC_DEFINE(NO_GETWD)) +AC_FUNC_CHECK(wait3, , AC_DEFINE(NO_WAIT3)) + +#-------------------------------------------------------------------- +# Supply substitutes for missing POSIX header files. Special +# notes: +# - Sprite's dirent.h exists but is bogus. +# - stdlib.h doesn't define strtol, strtoul, or +# strtod insome versions of SunOS +# - some versions of string.h don't declare procedures such +# as strstr +#-------------------------------------------------------------------- + +AC_UNISTD_H +AC_COMPILE_CHECK(dirent.h, [#include <sys/types.h> +#include <dirent.h>], [ +DIR *d; +struct dirent *entryPtr; +char *p; +d = opendir("foobar"); +entryPtr = readdir(d); +p = entryPtr->d_name; +closedir(d); +], tcl_ok=1, tcl_ok=0) +AC_HEADER_EGREP([Sprite version.* NOT POSIX], tcl_ok=0) +if test $tcl_ok = 0; then + AC_DEFINE(NO_DIRENT_H) +fi +AC_HEADER_CHECK(errno.h, , AC_DEFINE(NO_ERRNO_H)) +AC_HEADER_CHECK(float.h, , AC_DEFINE(NO_FLOAT_H)) +AC_HEADER_CHECK(limits.h, , AC_DEFINE(NO_LIMITS_H)) +AC_HEADER_CHECK(stdlib.h, tcl_ok=1, tcl_ok=0) +AC_HEADER_EGREP(strtol, stdlib.h, , tcl_ok=0) +AC_HEADER_EGREP(strtoul, stdlib.h, , tcl_ok=0) +AC_HEADER_EGREP(strtod, stdlib.h, , tcl_ok=0) +if test $tcl_ok = 0; then + AC_DEFINE(NO_STDLIB_H) +fi +AC_HEADER_CHECK(string.h, tcl_ok=1, tcl_ok=0) +AC_HEADER_EGREP(strstr, string.h, , tcl_ok=0) +AC_HEADER_EGREP(strerror, string.h, , tcl_ok=0) +if test $tcl_ok = 0; then + AC_DEFINE(NO_STRING_H) +fi +AC_HEADER_CHECK(sys/time.h, , AC_DEFINE(NO_SYS_TIME_H)) +AC_HEADER_CHECK(sys/wait.h, , AC_DEFINE(NO_SYS_WAIT_H)) + +#-------------------------------------------------------------------- +# On some systems strstr is broken: it returns a pointer even +# even if the original string is empty. +#-------------------------------------------------------------------- + +AC_TEST_PROGRAM([ +extern int strstr(); +int main() +{ + exit(strstr("\0test", "test") ? 1 : 0); +} +], , [LIBOBJS="$LIBOBJS strstr.o"]) + +#-------------------------------------------------------------------- +# Check for strtoul function. This is tricky because under some +# versions of AIX strtoul returns an incorrect terminator +# pointer for the string "0". +#-------------------------------------------------------------------- + +AC_FUNC_CHECK(strtoul, tcl_ok=1, tcl_ok=0) +AC_TEST_PROGRAM([ +extern int strtoul(); +int main() +{ + char *string = "0"; + char *term; + int value; + value = strtoul(string, &term, 0); + if ((value != 0) || (term != (string+1))) { + exit(1); + } + exit(0); +}], , tcl_ok=0) +if test $tcl_ok = 0; then + LIBOBJS="$LIBOBJS strtoul.o" +fi + +#-------------------------------------------------------------------- +# Check for the strtod function. This is tricky because under +# some versions of Linux it mis-parses the string "+". +#-------------------------------------------------------------------- + +AC_FUNC_CHECK(strtod, tcl_ok=1, tcl_ok=0) +AC_TEST_PROGRAM([ +extern double strtod(); +int main() +{ + char *string = "+"; + char *term; + double value; + value = strtod(string, &term); + if (term != string) { + exit(1); + } + exit(0); +}], , tcl_ok=0) +if test $tcl_ok = 0; then + LIBOBJS="$LIBOBJS strtod.o" +fi + +#-------------------------------------------------------------------- +# Check for various typedefs and provide substitutes if +# they don't exist. +#-------------------------------------------------------------------- + +AC_MODE_T +AC_PID_T +AC_SIZE_T +AC_UID_T + +#-------------------------------------------------------------------- +# If a system doesn't have an opendir function (man, that's old!) +# then we have to supply a different version of dirent.h which +# is compatible with the substitute version of opendir that's +# provided. This version only works with V7-style directories. +#-------------------------------------------------------------------- + +AC_FUNC_CHECK(opendir, , AC_DEFINE(USE_DIRENT2_H)) + +#-------------------------------------------------------------------- +# Check for the existence of sys_errlist (this is only needed if +# there's no strerror, but I don't know how to conditionalize the +# check). +#-------------------------------------------------------------------- + +AC_COMPILE_CHECK(sys_errlist, , [ +extern char *sys_errlist[]; +extern int sys_nerr; +sys_errlist[sys_nerr-1][0] = 0; +], , AC_DEFINE(NO_SYS_ERRLIST)) + +#-------------------------------------------------------------------- +# The check below checks whether <sys/wait.h> defines the type +# "union wait" correctly. It's needed because of weirdness in +# HP-UX where "union wait" is defined in both the BSD and SYS-V +# environments. Checking the usability of WIFEXITED seems to do +# the trick. +#-------------------------------------------------------------------- + +AC_COMPILE_CHECK([union wait], [#include <sys/types.h> +#include <sys/wait.h>], [ +union wait x; +WIFEXITED(x); /* Generates compiler error if WIFEXITED + * uses an int. */ +], , AC_DEFINE(NO_UNION_WAIT)) + +#-------------------------------------------------------------------- +# Check to see whether the system supports the matherr function +# and its associated type "struct exception". +#-------------------------------------------------------------------- + +AC_COMPILE_CHECK([matherr support], [#include <math.h>], [ +struct exception x; +x.type = DOMAIN; +x.type = SING; +], [LIBOBJS="$LIBOBJS tclMtherr.o"; AC_DEFINE(NEED_MATHERR)]) + +AC_OUTPUT(Makefile) diff --git a/vendor/x11iraf/obm/Tcl/configure.info b/vendor/x11iraf/obm/Tcl/configure.info new file mode 100755 index 00000000..1b15d613 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/configure.info @@ -0,0 +1,81 @@ +This file provides more information about the "configure" script +and how you can personalize it for your local environment. + +The `configure' shell script attempts to guess correct values for +various system-dependent variables used during compilation, and +creates the Makefile. It also creates a file `config.status' +that you can run in the future to recreate the current configuration. + +Running `configure' takes a minute or two. While it is running, it +prints some messages that tell what it is doing. If you don't want to +see the messages, run `configure' with its standard output redirected +to `/dev/null'; for example, `./configure >/dev/null'. + +To compile the package in a different directory from the one +containing the source code, you must use a version of make that +supports the VPATH variable, such as GNU make. `cd' to the directory +where you want the object files and executables to go and run +`configure'. `configure' automatically checks for the source code in +the directory that `configure' is in and in `..'. If for some reason +`configure' is not in the source code directory that you are +configuring, then it will report that it can't find the source code. +In that case, run `configure' with the option `--srcdir=DIR', where +DIR is the directory that contains the source code. + +By default, `make install' will install the package's files in +/usr/local/bin, /usr/local/lib, /usr/local/man, etc. You can specify +an installation prefix other than /usr/local by giving `configure' the +option `--prefix=PATH'. Alternately, you can do so by giving a value +for the `prefix' variable when you run `make', e.g., + make prefix=/usr/gnu + +You can specify separate installation prefixes for +architecture-specific files and architecture-independent files. If +you give `configure' the option `--exec_prefix=PATH' or set the +`make' variable `exec_prefix' to PATH, the package will use PATH as +the prefix for installing programs and libraries. Data files and +documentation will still use the regular prefix. Normally, all files +are installed using the regular prefix. + +You can tell `configure' to figure out the configuration for your +system, and record it in `config.status', without actually configuring +the package (creating `Makefile's and perhaps a configuration header +file). To do this, give `configure' the `--no-create' option. Later, +you can run `./config.status' to actually configure the package. This +option is useful mainly in `Makefile' rules for updating `config.status' +and `Makefile'. You can also give `config.status' the `--recheck' +option, which makes it re-run `configure' with the same arguments you +used before. This is useful if you change `configure'. + +`configure' ignores any other arguments that you give it. + +If your system requires unusual options for compilation or linking +that `configure' doesn't know about, you can give `configure' initial +values for some variables by setting them in the environment. In +Bourne-compatible shells, you can do that on the command line like +this: + CC='gcc -traditional' DEFS=-D_POSIX_SOURCE ./configure + +The `make' variables that you might want to override with environment +variables when running `configure' are: + +(For these variables, any value given in the environment overrides the +value that `configure' would choose:) +CC C compiler program. + Default is `cc', or `gcc' if `gcc' is in your PATH. +INSTALL Program to use to install files. + Default is `install' if you have it, `cp' otherwise. + +(For these variables, any value given in the environment is added to +the value that `configure' chooses:) +DEFS Configuration options, in the form `-Dfoo -Dbar ...' +LIBS Libraries to link with, in the form `-lfoo -lbar ...' + +If you need to do unusual things to compile the package, we encourage +you to figure out how `configure' could check whether to do them, and +mail diffs or instructions to the address given in the README so we +can include them in the next release. + +The file `configure.in' is used as a template to create `configure' by +a program called `autoconf'. You will only need it if you want to +regenerate `configure' using a newer version of `autoconf'. diff --git a/vendor/x11iraf/obm/Tcl/doc/AddErrInfo.3 b/vendor/x11iraf/obm/Tcl/doc/AddErrInfo.3 new file mode 100644 index 00000000..0ed3da3b --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/doc/AddErrInfo.3 @@ -0,0 +1,143 @@ +'\" +'\" Copyright (c) 1989-1993 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 +'\" documentation for any purpose, provided that the above copyright +'\" notice and the following two paragraphs appear in all copies. +'\" +'\" 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 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. +'\" +'\" $Header: /user6/ouster/tcl/man/RCS/AddErrInfo.3,v 1.15 93/04/08 13:54:29 ouster Exp $ SPRITE (Berkeley) +'\" +.so man.macros +.HS Tcl_AddErrorInfo tclc +.BS +.SH NAME +Tcl_AddErrorInfo, Tcl_SetErrorCode, Tcl_PosixError \- record information about errors +.SH SYNOPSIS +.nf +\fB#include <tcl.h>\fR +.sp +\fBTcl_AddErrorInfo\fR(\fIinterp, message\fR) +.sp +\fBTcl_SetErrorCode\fR(\fIinterp, element, element, ...\fB (char *) NULL\fR) +.sp +char * +\fBTcl_PosixError\fR(\fIinterp\fR) +.SH ARGUMENTS +.AS Tcl_Interp *message +.AP Tcl_Interp *interp in +Interpreter in which to record information. +.AP char *message in +Identifying string to record in \fBerrorInfo\fR variable. +.AP char *element in +String to record as one element of \fBerrorCode\fR variable. +Last \fIelement\fR argument must be NULL. +.BE + +.SH DESCRIPTION +.PP +These procedures are used to manipulate two global variables +that hold information about errors. +The variable \fBerrorInfo\fR holds a stack trace of the +operations that were in progress when an error occurred, and +is intended to be human-readable. +The variable \fBerrorCode\fR holds a list of items that +are intended to be machine-readable. +The first item in \fBerrorCode\fR identifies the class of +.VS +error that occurred (e.g. POSIX means an error occurred in +.VE +a POSIX system call) and additional elements in \fBerrorCode\fR +hold additional pieces of information that depend on the class. +See the Tcl overview manual entry for details on the various +formats for \fBerrorCode\fR. +.PP +The \fBerrorInfo\fR variable is gradually built up as an +error unwinds through the nested operations. +Each time an error code is returned to \fBTcl_Eval\fR +it calls the procedure \fBTcl_AddErrorInfo\fR to add +additional text to \fBerrorInfo\fR describing the +command that was being executed when the error occurred. +By the time the error has been passed all the way back +to the application, it will contain a complete trace +of the activity in progress when the error occurred. +.PP +It is sometimes useful to add additional information to +\fBerrorInfo\fR beyond what can be supplied automatically +by \fBTcl_Eval\fR. +\fBTcl_AddErrorInfo\fR may be used for this purpose: +its \fImessage\fR argument contains an additional +string to be appended to \fBerrorInfo\fR. +For example, the \fBsource\fR command calls \fBTcl_AddErrorInfo\fR +to record the name of the file being processed and the +line number on which the error occurred; for Tcl procedures, the +procedure name and line number within the procedure are recorded, +and so on. +The best time to call \fBTcl_AddErrorInfo\fR is just after +\fBTcl_Eval\fR has returned \fBTCL_ERROR\fR. +In calling \fBTcl_AddErrorInfo\fR, you may find it useful to +use the \fBerrorLine\fR field of the interpreter (see the +\fBTcl_Interp\fR manual entry for details). +.PP +The procedure \fBTcl_SetErrorCode\fR is used to set the +\fBerrorCode\fR variable. +Its \fIelement\fR arguments give one or more strings to record +in \fBerrorCode\fR: each \fIelement\fR will become one item +of a properly-formed Tcl list stored in \fBerrorCode\fR. +\fBTcl_SetErrorCode\fR is typically invoked just before returning +an error. +If an error is returned without calling \fBTcl_SetErrorCode\fR +then the Tcl interpreter automatically sets \fBerrorCode\fR +to \fBNONE\fR. +.PP +\fBTcl_PosixError\fR +.VS +sets the \fBerrorCode\fR variable after an error in a POSIX kernel call. +It reads the value of the \fBerrno\fR C variable and calls +\fBTcl_SetErrorCode\fR to set \fBerrorCode\fR in the +\fBPOSIX\fR format. +In addition, \fBTcl_PosixError\fR returns a human-readable +.VE +diagnostic message for the error (this is the same value that +will appear as the third element in \fBerrorCode\fR). +It may be convenient to include this string as part of the +error message returned to the application in \fIinterp->result\fR. +.PP +It is important to call the procedures described here rather than +setting \fBerrorInfo\fR or \fBerrorCode\fR directly with +\fBTcl_SetVar\fR. +The reason for this is that the Tcl interpreter keeps information +about whether these procedures have been called. +For example, the first time \fBTcl_AppendResult\fR is called +for an error, it clears the existing value of \fBerrorInfo\fR +and adds the error message in \fIinterp->result\fR to the variable +before appending \fImessage\fR; in subsequent calls, it just +appends the new \fImessage\fR. +When \fBTcl_SetErrorCode\fR is called, it sets a flag indicating +that \fBerrorCode\fR has been set; this allows the Tcl interpreter +to set \fBerrorCode\fR to \fBNONE\fB if it receives an error return +when \fBTcl_SetErrorCode\fR hasn't been called. +.PP +If the procedure \fBTcl_ResetResult\fR is called, it clears all +of the state associated with \fBerrorInfo\fR and \fBerrorCode\fR +(but it doesn't actually modify the variables). +If an error had occurred, this will clear the error state to +make it appear as if no error had occurred after all. + +.SH "SEE ALSO" +Tcl_ResetResult, Tcl_Interp + +.SH KEYWORDS +error, stack, trace, variable diff --git a/vendor/x11iraf/obm/Tcl/doc/AppInit.3 b/vendor/x11iraf/obm/Tcl/doc/AppInit.3 new file mode 100644 index 00000000..e957926b --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/doc/AppInit.3 @@ -0,0 +1,68 @@ +'\" +'\" Copyright (c) 1993 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 +'\" documentation for any purpose, provided that the above copyright +'\" notice and the following two paragraphs appear in all copies. +'\" +'\" 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 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. +'\" +'\" $Header: /user6/ouster/tcl/man/RCS/AppInit.3,v 1.2 93/06/07 15:11:46 ouster Exp $ SPRITE (Berkeley) +'\" +.so man.macros +.HS Tcl_AppInit tclc 7.0 +.BS +.SH NAME +Tcl_AppInit \- Perform application-specific initialization +.SH SYNOPSIS +.nf +\fB#include <tcl.h>\fR +.sp +\fBTcl_AppInit\fR(\fIinterp\fR) +.SH ARGUMENTS +.AS Tcl_Interp *interp +.AP Tcl_Interp *interp in +Interpreter for the application. +.BE + +.SH DESCRIPTION +.PP +\fBTcl_AppInit\fR is a procedure that is invoked by the main programs +for Tcl applications such as \fBtclsh\fR and \fBwish\fR. +Its purpose is to allow new Tcl applications to be created without +modifying existing main programs such as those for \fBtclsh\fR +and \fBwish\fR. +To create a new application simply write a new version of +\fBTcl_AppInit\fR to replace the default version provided by Tcl, +then link your new \fBTcl_AppInit\fR with the Tcl library, which +contains the main program from \fBtclsh\fR (be sure to specify the +switch ``\fB\-u _main\fR'' to the linker to force it to use the +version of \fBmain\fR from the Tcl library). +.PP +\fBTcl_AppInit\fR is invoked after other initialization in +\fBmain\fR and before entering the main loop to process commands. +Here are some examples of things that \fBTcl_AppInit\fR might do: +.IP [1] +Call initialization procedures for various packages used by +the application. +Each initialization procedure adds new commands to \fIinterp\fR +for its package and performs other package-specific initialization. +.IP [2] +Process command-line arguments, which can be accessed from the +Tcl variables \fBargv\fR and \fBargv0\fR in \fIinterp\fR. +.IP [3] +Invoke a startup script to initialize the application. + +.SH KEYWORDS +application, argument, command, initialization, interpreter diff --git a/vendor/x11iraf/obm/Tcl/doc/Async.3 b/vendor/x11iraf/obm/Tcl/doc/Async.3 new file mode 100644 index 00000000..730284d8 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/doc/Async.3 @@ -0,0 +1,172 @@ +'\" +'\" Copyright (c) 1989-1993 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 +'\" documentation for any purpose, provided that the above copyright +'\" notice and the following two paragraphs appear in all copies. +'\" +'\" 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 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. +'\" +'\" $Header: /user6/ouster/tcl/man/RCS/Async.3,v 1.5 93/09/17 15:21:50 ouster Exp $ SPRITE (Berkeley) +'\" +.so man.macros +.HS Tcl_AsyncCreate tclc 7.0 +.BS +.SH NAME +Tcl_AsyncCreate, Tcl_AsyncMark, Tcl_AsyncInvoke, Tcl_AsyncDelete \- handle asynchronous events +.SH SYNOPSIS +.nf +\fB#include <tcl.h>\fR +.sp +extern int \fBtcl_AsyncReady\fR; +.sp +Tcl_AsyncHandler +\fBTcl_AsyncCreate\fR(\fIproc, clientData\fR) +.sp +\fBTcl_AsyncMark\fR(\fIasync\fR) +.sp +int +\fBTcl_AsyncInvoke\fR(\fIinterp, code\fR) +.sp +\fBTcl_AsyncDelete\fR(\fIasync\fR) +.SH ARGUMENTS +.AS Tcl_AsyncHandler clientData +.AP Tcl_AsyncProc *proc in +Procedure to invoke to handle an asynchronous event. +.AP ClientData clientData in +One-word value to pass to \fIproc\fR. +.AP Tcl_AsyncHandler async in +Token for asynchronous event handler. +.AP Tcl_Interp *interp in +Tcl interpreter in which command was being evaluated when handler was +invoked, or NULL if handler was invoked when there was no interpreter +active. +.AP int code in +Completion code from command that just completed in \fIinterp\fR, +or 0 if \fIinterp\fR is NULL. +.BE + +.SH DESCRIPTION +.PP +These procedures provide a safe mechanism for dealing with +asynchronous events such as signals. +If an event such as a signal occurs while a Tcl script is being +evaluated then it isn't safe to take any substantive action to +process the event. +For example, it isn't safe to evaluate a Tcl script since the +intepreter may already be in the middle of evaluating a script; +it may not even be safe to allocate memory, since a memory +allocation could have been in progress when the event occurred. +The only safe approach is to set a flag indicating that the event +occurred, then handle the event later when the world has returned +to a clean state, such as after the current Tcl command completes. +.PP +\fBTcl_AsyncCreate\fR creates an asynchronous handler and returns +a token for it. +The asynchronous handler must be created before +any occurrences of the asynchronous event that it is intended +to handle (it is not safe to create a handler at the time of +an event). +When an asynchronous event occurs the code that detects the event +(such as a signal handler) should call \fBTcl_AsyncMark\fR with the +token for the handler. +\fBTcl_AsyncMark\fR will mark the handler as ready to execute, but it +will not invoke the handler immediately. +Tcl will call the \fIproc\fR associated with the handler later, when +the world is in a safe state, and \fIproc\fR can then carry out +the actions associated with the asynchronous event. +\fIProc\fR should have arguments and result that match the +type \fBTcl_AsyncProc\fR: +.nf +.RS +typedef int Tcl_AsyncProc( +.RS +ClientData \fIclientData\fR, +Tcl_Interp *\fIinterp\fR, +int \fIcode\fR); +.RE +.RE +.fi +The \fIclientData\fR will be the same as the \fIclientData\fR +argument passed to \fBTcl_AsyncCreate\fR when the handler was +created. +If \fIproc\fR is invoked just after a command has completed +execution in an interpreter, then \fIinterp\fR will identify +the interpreter in which the command was evaluated and +\fIcode\fR will be the completion code returned by that +command. +The command's result will be present in \fIinterp->result\fR. +When \fIproc\fR returns, whatever it leaves in \fIinterp->result\fR +will be returned as the result of the command and the integer +value returned by \fIproc\fR will be used as the new completion +code for the command. +.PP +It is also possible for \fIproc\fR to be invoked when no interpreter +is active. +This can happen, for example, if an asynchronous event occurs while +the application is waiting for interactive input or an X event. +In this case \fIinterp\fR will be NULL and \fIcode\fR will be +0, and the return value from \fIproc\fR will be ignored. +.PP +The procedure \fBTcl_AsyncInvoke\fR is called to invoke all of the +handlers that are ready. +The global variable \fBtcl_AsyncReady\fR will be non-zero whenever any +asynchronous handlers are ready; it can be checked to avoid calls +to \fBTcl_AsyncInvoke\fR when there are no ready handlers. +Tcl checks \fBtcl_AsyncReady\fR after each command is evaluated +and calls \fBTcl_AsyncInvoke\fR if needed. +Applications may also call \fBTcl_AsyncInvoke\fR at interesting +times for that application. +For example, Tk's event handler checks \fBtcl_AsyncReady\fR +after each event and calls \fBTcl_AsyncInvoke\fR if needed. +The \fIinterp\fR and \fIcode\fR arguments to \fBTcl_AsyncInvoke\fR +have the same meaning as for \fIproc\fR: they identify the active +intepreter, if any, and the completion code from the command +that just completed. +.PP +\fBTcl_AsyncDelete\fR removes an asynchronous handler so that +its \fIproc\fR will never be invoked again. +A handler can be deleted even when ready, and it will still +not be invoked. +.PP +If multiple handlers become active at the same time, the +handlers are invoked in the order they were created (oldest +handler first). +The \fIcode\fR and \fIinterp->result\fR for later handlers +reflect the values returned by earlier handlers, so that +the most recently created handler has last say about +the interpreter's result and completion code. +If new handlers become ready while handlers are executing, +\fBTcl_AsyncInvoke\fR will invoke them all; at each point it +invokes the highest-priority (oldest) ready handler, repeating +this over and over until there are no longer any ready handlers. + +.SH WARNING +.PP +It is almost always a bad idea for an asynchronous event +handler to modify \fIinterp->result\fR or return a code different +from its \fIcode\fR argument. +This sort of behavior can disrupt the execution of scripts in +subtle ways and result in bugs that are extremely difficult +to track down. +If an asynchronous event handler needs to evaluate Tcl scripts +then it should first save \fIinterp->result\fR plus the values +of the variables \fBerrorInfo\fR and \fBerrorCode\fR (this can +be done, for example, by storing them in dynamic strings). +When the asynchronous handler is finished it should restore +\fIinterp->result\fR, \fBerrorInfo\fR, and \fBerrorCode\fR, +and return the \fIcode\fR argument. + +.SH KEYWORDS +asynchronous event, handler, signal diff --git a/vendor/x11iraf/obm/Tcl/doc/Backslash.3 b/vendor/x11iraf/obm/Tcl/doc/Backslash.3 new file mode 100644 index 00000000..e8b0325d --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/doc/Backslash.3 @@ -0,0 +1,58 @@ +'\" +'\" Copyright (c) 1989-1993 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 +'\" documentation for any purpose, provided that the above copyright +'\" notice and the following two paragraphs appear in all copies. +'\" +'\" 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 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. +'\" +'\" $Header: /user6/ouster/tcl/man/RCS/Backslash.3,v 1.12 93/04/01 09:25:22 ouster Exp $ SPRITE (Berkeley) +'\" +.so man.macros +.HS Tcl_Backslash tclc +.BS +.SH NAME +Tcl_Backslash \- parse a backslash sequence +.SH SYNOPSIS +.nf +\fB#include <tcl.h>\fR +.sp +char +\fBTcl_Backslash\fR(\fIsrc, countPtr\fR) +.SH ARGUMENTS +.AS char *countPtr +.AP char *src in +Pointer to a string starting with a backslash. +.AP int *countPtr out +If \fIcountPtr\fR isn't NULL, \fI*countPtr\fR gets filled +in with number of characters in the backslash sequence, including +the backslash character. +.BE + +.SH DESCRIPTION +.PP +This is a utility procedure used by several of the Tcl +commands. It parses a backslash sequence and returns +the single character corresponding to the sequence. +\fBTcl_Backslash\fR modifies \fI*countPtr\fR to contain the number +of characters in the backslash sequence. +.PP +See the Tcl manual entry for information on the valid +backslash sequences. +All of the sequences described in the Tcl +manual entry are supported by \fBTcl_Backslash\fR. + +.SH KEYWORDS +backslash, parse diff --git a/vendor/x11iraf/obm/Tcl/doc/CallDel.3 b/vendor/x11iraf/obm/Tcl/doc/CallDel.3 new file mode 100644 index 00000000..1454ca36 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/doc/CallDel.3 @@ -0,0 +1,82 @@ +'\" +'\" Copyright (c) 1993 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 +'\" documentation for any purpose, provided that the above copyright +'\" notice and the following two paragraphs appear in all copies. +'\" +'\" 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 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. +'\" +'\" $Header: /user6/ouster/tcl/man/RCS/CallDel.3,v 1.3 93/09/09 16:49:23 ouster Exp $ SPRITE (Berkeley) +'\" +.so man.macros +.HS Tcl_CallWhenDeleted tclc 7.0 +.BS +.SH NAME +.na +Tcl_CallWhenDeleted, Tcl_DontCallWhenDeleted \- Arrange for callback when interpreter is deleted +.ad +.SH SYNOPSIS +.nf +\fB#include <tcl.h>\fR +.sp +\fBTcl_CallWhenDeleted\fR(\fIinterp\fR, \fIproc\fR, \fIclientData\fR) +.sp +\fBTcl_DontCallWhenDeleted\fR(\fIinterp\fR, \fIproc\fR, \fIclientData\fR) +.SH ARGUMENTS +.AS Tcl_InterpDeleteProc clientData +.AP Tcl_Interp *interp in +Interpreter with which to associated callback. +.AP Tcl_InterpDeleteProc *proc in +Procedure to call when \fIinterp\fR is deleted. +.AP ClientData clientData in +Arbitrary one-word value to pass to \fIproc\fR. +.BE + +.SH DESCRIPTION +.PP +\fBTcl_CallWhenDeleted\fR arranges for \fIproc\fR to be called by +\fBTcl_DeleteInterp\fR if/when \fIinterp\fR is deleted at some future +time. \fIProc\fR will be invoked just before the interpreter +is deleted, but the interpreter will still be valid at the +time of the call. +\fIProc\fR should have arguments and result that match the +type \fBTcl_InterpDeleteProc\fR: +.nf +.RS +typedef int Tcl_InterpDeleteProc( +.RS +ClientData \fIclientData\fR, +Tcl_Interp *\fIinterp\fR); +.RE +.RE +.fi +The \fIclientData\fP and \fIinterp\fR parameters are +copies of the \fIclientData\fP and \fIinterp\fR arguments given +to \fBTcl_CallWhenDeleted\fR. +Typically, \fIclientData\fR points to an application-specific +data structure that \fIproc\fR uses to perform cleanup when an +interpreter is about to go away. +\fIProc\fR does not return a value. +.PP +\fBTcl_DontCallWhenDeleted\fR cancels a previous call to +\fBTcl_CallWhenDeleted\fR with the same arguments, so that +\fIproc\fR won't be called after all when \fIinterp\fR is +deleted. +If there is no deletion callback that matches \fIinterp\fR, +\fIproc\fR, and \fIclientData\fR then the call to +\fBTcl_DontCallWhenDeleted\fR has no effect. + +.SH KEYWORDS +callback, delete, interpreter diff --git a/vendor/x11iraf/obm/Tcl/doc/CmdCmplt.3 b/vendor/x11iraf/obm/Tcl/doc/CmdCmplt.3 new file mode 100644 index 00000000..968d6dfa --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/doc/CmdCmplt.3 @@ -0,0 +1,49 @@ +'\" +'\" Copyright (c) 1989-1993 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 +'\" documentation for any purpose, provided that the above copyright +'\" notice and the following two paragraphs appear in all copies. +'\" +'\" 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 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. +'\" +'\" $Header: /user6/ouster/tcl/man/RCS/CmdCmplt.3,v 1.1 93/04/05 10:04:55 ouster Exp $ SPRITE (Berkeley) +'\" +.so man.macros +.HS Tcl_CmdComplete tclc +.BS +.SH NAME +Tcl_CmdComplete \- Check for unmatched braces in a Tcl command +.SH SYNOPSIS +.nf +\fB#include <tcl.h>\fR +.sp +int +\fBTcl_CommandComplete\fR(\fIcmd\fR) +.SH ARGUMENTS +.AS char *cmd +.AP char *cmd in +Command string to test for completeness. +.BE + +.SH DESCRIPTION +.PP +\fBTcl_CommandComplete\fR takes a Tcl command string +as argument and determines whether it contains one or more +complete commands (i.e. there are no unclosed quotes, braces, +brackets, or variable references). +If the command string is complete then it returns 1; otherwise it returns 0. + +.SH KEYWORDS +complete command, partial command diff --git a/vendor/x11iraf/obm/Tcl/doc/Concat.3 b/vendor/x11iraf/obm/Tcl/doc/Concat.3 new file mode 100644 index 00000000..85096014 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/doc/Concat.3 @@ -0,0 +1,64 @@ +'\" +'\" Copyright (c) 1989-1993 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 +'\" documentation for any purpose, provided that the above copyright +'\" notice and the following two paragraphs appear in all copies. +'\" +'\" 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 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. +'\" +'\" $Header: /user6/ouster/tcl/man/RCS/Concat.3,v 1.6 93/04/01 09:25:23 ouster Exp $ SPRITE (Berkeley) +'\" +.so man.macros +.HS Tcl_Concat tclc +.BS +.SH NAME +Tcl_Concat \- concatenate a collection of strings +.SH SYNOPSIS +.nf +\fB#include <tcl.h>\fR +.sp +char * +\fBTcl_Concat\fR(\fIargc, argv\fR) +.SH ARGUMENTS +.AP int argc in +Number of strings. +.AP char *argv[] in +Array of strings to concatenate. Must have \fIargc\fR entries. +.BE + +.SH DESCRIPTION +.PP +\fBTcl_Concat\fR is a utility procedure used by several of the +Tcl commands. Given a collection of strings, it concatenates +them together into a single string, with the original strings +separated by spaces. This procedure behaves differently than +\fBTcl_Merge\fR, in that the arguments are simply concatenated: +no effort is made to ensure proper list structure. +However, in most common usage the arguments will all be proper +lists themselves; if this is true, then the result will also have +proper list structure. +.PP +\fBTcl_Concat\fR eliminates leading and trailing white space as it +copies strings from \fBargv\fR to the result. If an element of +\fBargv\fR consists of nothing but white space, then that string +is ignored entirely. This white-space removal was added to make +the output of the \fBconcat\fR command cleaner-looking. +.PP +The result string is dynamically allocated +using \fBmalloc()\fR; the caller must eventually release the space +by calling \fBfree()\fR. + +.SH KEYWORDS +concatenate, strings diff --git a/vendor/x11iraf/obm/Tcl/doc/CrtCommand.3 b/vendor/x11iraf/obm/Tcl/doc/CrtCommand.3 new file mode 100644 index 00000000..9f61f49d --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/doc/CrtCommand.3 @@ -0,0 +1,172 @@ +'\" +'\" Copyright (c) 1989-1993 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 +'\" documentation for any purpose, provided that the above copyright +'\" notice and the following two paragraphs appear in all copies. +'\" +'\" 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 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. +'\" +'\" $Header: /user6/ouster/tcl/man/RCS/CrtCommand.3,v 1.12 93/10/29 15:52:29 ouster Exp $ SPRITE (Berkeley) +'\" +.so man.macros +.HS Tcl_CreateCommand tclc +.BS +.SH NAME +Tcl_CreateCommand, Tcl_DeleteCommand, Tcl_GetCommandInfo, Tcl_SetCommandInfo \- implement new commands in C +.SH SYNOPSIS +.nf +\fB#include <tcl.h>\fR +.sp +\fBTcl_CreateCommand\fR(\fIinterp, cmdName, proc, clientData, deleteProc\fR) +.sp +int +\fBTcl_DeleteCommand\fR(\fIinterp, cmdName\fR) +.sp +.VS +int +\fBTcl_GetCommandInfo\fR(\fIinterp, cmdName, infoPtr\fR) +.sp +int +\fBTcl_SetCommandInfo\fR(\fIinterp, cmdName, infoPtr\fR) +.VE +.SH ARGUMENTS +.AS Tcl_CmdDeleteProc **deleteProcPtr +.AP Tcl_Interp *interp in +Interpreter in which to create new command. +.AP char *cmdName in +Name of command. +.AP Tcl_CmdProc *proc in +Implementation of new command: \fIproc\fR will be called whenever +\fIcmdName\fR is invoked as a command. +.AP ClientData clientData in +Arbitrary one-word value to pass to \fIproc\fR and \fIdeleteProc\fR. +.AP Tcl_CmdDeleteProc *deleteProc in +Procedure to call before \fIcmdName\fR is deleted from the interpreter; +allows for command-specific cleanup. If NULL, then no procedure is +called before the command is deleted. +.AP Tcl_CmdInfo *infoPtr in/out +.VS +Pointer to structure containing various information about a +Tcl command. +.VE +.BE + +.SH DESCRIPTION +.PP +\fBTcl_CreateCommand\fR defines a new command in \fIinterp\fR and associates +it with procedure \fIproc\fR such that whenever \fIcmdName\fR is +invoked as a Tcl command (via a call to \fBTcl_Eval\fR) the Tcl interpreter +will call \fIproc\fR +to process the command. If there is already a command \fIcmdName\fR +associated with the interpreter, it is deleted. \fIProc\fP should +have arguments and result that match the type \fBTcl_CmdProc\fR: +.nf +.RS +typedef int Tcl_CmdProc( +.RS +ClientData \fIclientData\fR, +Tcl_Interp *\fIinterp\fR, +int \fIargc\fR, +char *\fIargv\fR[]); +.RE +.RE +.fi +When \fIproc\fR is invoked the \fIclientData\fP and \fIinterp\fR +parameters will be copies of the \fIclientData\fP and \fIinterp\fR +arguments given to \fBTcl_CreateCommand\fR. +Typically, \fIclientData\fR points to an application-specific +data structure that describes what to do when the command procedure +is invoked. \fIArgc\fR and \fIargv\fR describe the arguments to +the command, \fIargc\fR giving the number of arguments (including +the command name) and \fIargv\fR giving the values of the arguments +as strings. The \fIargv\fR array will contain \fIargc\fR+1 values; +the first \fIargc\fR values point to the argument strings, and the +last value is NULL. +.PP +\fIProc\fR must return an integer code that is either \fBTCL_OK\fR, \fBTCL_ERROR\fR, +\fBTCL_RETURN\fR, \fBTCL_BREAK\fR, or \fBTCL_CONTINUE\fR. See the Tcl overview man page +for details on what these codes mean. Most normal commands will only +return \fBTCL_OK\fR or \fBTCL_ERROR\fR. In addition, \fIproc\fR must set +\fIinterp->result\fR to point to a string value; +in the case of a \fBTCL_OK\fR return code this gives the result +of the command, and in the case of \fBTCL_ERROR\fR it gives an error message. +The \fBTcl_SetResult\fR procedure provides an easy interface for setting +the return value; for complete details on how the \fIinterp->result\fR +field is managed, see the \fBTcl_Interp\fR man page. +Before invoking a command procedure, +\fBTcl_Eval\fR sets \fIinterp->result\fR to point to an empty string, so simple +commands can return an empty result by doing nothing at all. +.PP +.VS +The contents of the \fIargv\fR array belong to Tcl and are not +guaranteed to persist once \fIproc\fR returns: \fIproc\fR should +not modify them, nor should it set \fIinterp->result\fR to point +anywhere within the \fIargv\fR values. +Call \fBTcl_SetResult\fR with status \fBTCL_VOLATILE\fR if you want +to return something from the \fIargv\fR array. +.VE +.PP +\fIDeleteProc\fR will be invoked when (if) \fIcmdName\fR is deleted. +This can occur through a call to \fBTcl_DeleteCommand\fR or \fBTcl_DeleteInterp\fR, +or by replacing \fIcmdName\fR in another call to \fBTcl_CreateCommand\fR. +\fIDeleteProc\fR is invoked before the command is deleted, and gives the +application an opportunity to release any structures associated +with the command. \fIDeleteProc\fR should have arguments and +result that match the type \fBTcl_CmdDeleteProc\fR: +.nf +.RS +.sp +typedef void Tcl_CmdDeleteProc(ClientData \fIclientData\fR); +.sp +.RE +.fi +The \fIclientData\fR argument will be the same as the \fIclientData\fR +argument passed to \fBTcl_CreateCommand\fR. +.PP +\fBTcl_DeleteCommand\fR deletes a command from a command interpreter. +Once the call completes, attempts to invoke \fIcmdName\fR in +\fIinterp\fR will result in errors. +If \fIcmdName\fR isn't bound as a command in \fIinterp\fR then +\fBTcl_DeleteCommand\fR does nothing and returns -1; otherwise +it returns 0. +There are no restrictions on \fIcmdName\fR: it may refer to +a built-in command, an application-specific command, or a Tcl procedure. +.PP +.VS +\fBTcl_GetCommandInfo\fR checks to see whether its \fIcmdName\fR argument +exists as a command in \fIinterp\fR. If not then it returns 0. +Otherwise it places information about the command in the structure +pointed to by \fIinfoPtr\fR and returns 1. +Tcl_CmdInfo structures have fields named \fIproc\fR, \fIclientData\fR, +and \fIdeleteProc\fR, which have the same meaning as the corresponding +arguments to \fBTcl_CreateCommand\fR. +There is also a field \fIdeleteData\fR, which is the ClientData value +to pass to \fIdeleteProc\fR; it is normally the same as +\fIclientData\fR but may be set independently using the +\fBTcl_SetCommandInfo\fR procedure. +.PP +\fBTcl_SetCommandInfo\fR is used to modify the procedures and +ClientData values associated with a command. +Its \fIcmdName\fR argument is the name of a command in \fIinterp\fR. +If this command exists then \fBTcl_SetCommandInfo\fR returns 0. +Otherwise, it copies the information from \fI*infoPtr\fR to +Tcl's internal structure for the command and returns 1. +Note that this procedure allows the ClientData for a command's +deletion procedure to be given a different value than the ClientData +for its command procedure. +.VE + +.SH KEYWORDS +bind, command, create, delete, interpreter diff --git a/vendor/x11iraf/obm/Tcl/doc/CrtInterp.3 b/vendor/x11iraf/obm/Tcl/doc/CrtInterp.3 new file mode 100644 index 00000000..c987801c --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/doc/CrtInterp.3 @@ -0,0 +1,61 @@ +'\" +'\" Copyright (c) 1989-1993 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 +'\" documentation for any purpose, provided that the above copyright +'\" notice and the following two paragraphs appear in all copies. +'\" +'\" 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 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. +'\" +'\" $Header: /user6/ouster/tcl/man/RCS/CrtInterp.3,v 1.7 93/04/01 09:25:24 ouster Exp $ SPRITE (Berkeley) +'\" +.so man.macros +.HS Tcl_CreateInterp tclc +.BS +.SH NAME +Tcl_CreateInterp, Tcl_DeleteInterp \- create and delete Tcl command interpreters +.SH SYNOPSIS +.nf +\fB#include <tcl.h>\fR +.sp +Tcl_Interp * +\fBTcl_CreateInterp\fR() +.sp +\fBTcl_DeleteInterp\fR(\fIinterp\fR) +.SH ARGUMENTS +.AS Tcl_Interp *interp +.AP Tcl_Interp *interp in +Token for interpreter to be destroyed. +.BE + +.SH DESCRIPTION +.PP +\fBTcl_CreateInterp\fR creates a new interpreter structure and returns +a token for it. The token is required in calls to most other Tcl +procedures, such as \fBTcl_CreateCommand\fR, \fBTcl_Eval\fR, and +\fBTcl_DeleteInterp\fR. +Clients are only allowed to access a few of the fields of +Tcl_Interp structures; see the Tcl_Interp +and \fBTcl_CreateCommand\fR man pages for details. +The new interpreter is initialized with no defined variables and only +the built-in Tcl commands. To bind in additional commands, call +\fBTcl_CreateCommand\fR. +.PP +\fBTcl_DeleteInterp\fR destroys a command interpreter and releases all of +the resources associated with it, including variables, procedures, +and application-specific command bindings. After \fBTcl_DeleteInterp\fR +returns the caller should never again use the \fIinterp\fR token. + +.SH KEYWORDS +command, create, delete, interpreter diff --git a/vendor/x11iraf/obm/Tcl/doc/CrtMathFnc.3 b/vendor/x11iraf/obm/Tcl/doc/CrtMathFnc.3 new file mode 100644 index 00000000..1a48b6c1 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/doc/CrtMathFnc.3 @@ -0,0 +1,114 @@ +'\" +'\" Copyright (c) 1989-1993 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 +'\" documentation for any purpose, provided that the above copyright +'\" notice and the following two paragraphs appear in all copies. +'\" +'\" 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 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. +'\" +'\" $Header: /user6/ouster/tcl/man/RCS/CrtMathFnc.3,v 1.1 93/04/14 16:35:59 ouster Exp $ SPRITE (Berkeley) +'\" +.so man.macros +.HS Tcl_CreateMathFunc tclc 7.0 +.BS +.SH NAME +Tcl_CreateMathFunc \- Define a new math function for expressions +.SH SYNOPSIS +.nf +\fB#include <tcl.h>\fR +.sp +\fBTcl_CreateMathFunc\fR(\fIinterp, name, numArgs, argTypes, proc, clientData\fR) +.SH ARGUMENTS +.AS Tcl_ValueType clientData +.AP Tcl_Interp *interp in +Interpreter in which new function will be defined. +.AP char *name in +Name for new function. +.AP int numArgs in +Number of arguments to new function; also gives size of \fIargTypes\fR array. +.AP Tcl_ValueType *argTypes in +Points to an array giving the permissible types for each argument to +function. +.AP Tcl_MathProc *proc in +Procedure that implements the function. +.AP ClientData clientData in +Arbitrary one-word value to pass to \fIproc\fR when it is invoked. +.BE + +.SH DESCRIPTION +.PP +Tcl allows a number of mathematical functions to be used in +expressions, such as \fBsin\fR, \fBcos\fR, and \fBhypot\fR. +\fBTcl_CreateMathFunc\fR allows applications to add additional functions +to those already provided by Tcl or to replace existing functions. +\fIName\fR is the name of the function as it will appear in expressions. +If \fIname\fR doesn't already exist as a function then a new function +is created. If it does exist, then the existing function is replaced. +\fINumArgs\fR and \fIargTypes\fR describe the arguments to the function. +Each entry in the \fIargTypes\fR array must be either TCL_INT, TCL_DOUBLE, +or TCL_EITHER to indicate whether the corresponding argument must be an +integer, a double-precision floating value, or either, respectively. +.PP +Whenever the function is invoked in an expression Tcl will invoke +\fIproc\fR. \fIProc\fR should have arguments and result that match +the type \fBTcl_MathProc\fR: +.nf +.RS +typedef int Tcl_MathProc( +.RS +ClientData \fIclientData\fR, +Tcl_Interp *\fIinterp\fR, +Tcl_Value *\fIargs\fR, +Tcl_Value *resultPtr\fR); +.RE +.RE +.fi +.PP +When \fIproc\fR is invoked the \fIclientData\fR and \fIinterp\fR +arguments will be the same as those passed to \fBTcl_CreateMathFunc\fR. +\fIArgs\fR will point to an array of \fInumArgs\fR Tcl_Value structures, +which describe the actual arguments to the function: +.nf +.RS +typedef struct Tcl_Value { +.RS +Tcl_ValueType \fItype\fR; +int \fIintValue\fR; +double \fIdoubleValue\fR; +.RE +} Tcl_Value; +.RE +.fi +.PP +The \fItype\fR field indicates the type of the argument and is +either TCL_INT or TCL_DOUBLE. +It will match the \fIargTypes\fR value specified for the function unless +the \fIargTypes\fR value was TCL_EITHER. Tcl converts +the argument supplied in the expression to the type requested in +\fIargTypes\fR, if that is necessary. +Depending on the value of the \fItype\fR field, the \fIintValue\fR +or \fIdoubleValue\fR field will contain the actual value of the argument. +.PP +\fIProc\fR should compute its result and store it either as an integer +in \fIresultPtr->intValue\fR or as a floating value in +\fIresultPtr->doubleValue\fR. +It should set also \fIresultPtr->type\fR to either TCL_INT or TCL_DOUBLE +to indicate which value was set. +Under normal circumstances \fIproc\fR should return TCL_OK. +If an error occurs while executing the function, \fIproc\fR should +return TCL_ERROR and leave an error message in \fIinterp->result\fR. + +.SH KEYWORDS +expression, mathematical function diff --git a/vendor/x11iraf/obm/Tcl/doc/CrtPipelin.3 b/vendor/x11iraf/obm/Tcl/doc/CrtPipelin.3 new file mode 100644 index 00000000..f5064b6c --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/doc/CrtPipelin.3 @@ -0,0 +1,114 @@ +'\" +'\" Copyright (c) 1989-1993 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 +'\" documentation for any purpose, provided that the above copyright +'\" notice and the following two paragraphs appear in all copies. +'\" +'\" 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 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. +'\" +'\" $Header: /user6/ouster/tcl/man/RCS/CrtPipelin.3,v 1.7 93/04/09 11:53:47 ouster Exp $ SPRITE (Berkeley) +'\" +.so man.macros +.HS Tcl_CreatePipeline tclc +.BS +.SH NAME +Tcl_CreatePipeline \- create one or more child processes, with I/O redirection +.SH SYNOPSIS +.nf +\fB#include <tcl.h>\fR +.sp +int +\fBTcl_CreatePipeline\fR(\fIinterp, argc, argv, pidArrayPtr, inPipePtr, outPipePtr, errFilePtr\fR) +.SH ARGUMENTS +.AS Tcl_Interp **pidArrayPtr +.AP Tcl_Interp *interp in +Interpreter to use for error reporting. +.AP int argc in +Number of strings in \fIargv\fR array. +.AP char **argv in +Array of strings describing command(s) and I/O redirection. +.AP int **pidArrayPtr out +The value at \fI*pidArrayPtr\fR is modified to hold a pointer to +an array of process identifiers. The array is dynamically +allocated and must be freed by the caller. +.AP int *inPipePtr out +If this argument is NULL then standard input for the first command +in the pipeline comes from the current standard input. +If \fIinPipePtr\fR is not NULL then \fBTcl_CreatePipeline\fR will +create a pipe, arrange for it to be used for standard input +to the first command, +and store a file id for writing to that pipe at \fI*inPipePtr\fR. +If the command specified its own input using redirection, then +no pipe is created and -1 is stored at \fI*inPipePtr\fR. +.AP int *outPipePtr out +If this argument is NULL then standard output for the last command +in the pipeline goes to the current standard output. +If \fIoutPipePtr\fR is not NULL then \fBTcl_CreatePipeline\fR will +create a pipe, arrange for it to be used for standard output from +the last command, and store a file id for reading from that +pipe at \fI*outPipePtr\fR. +If the command specified its own output using redirection then +no pipe is created and -1 is stored at \fI*outPipePtr\fR. +.AP int *errFilePtr out +If this argument is NULL then error output for all the commands +in the pipeline will go to the current standard error file. +If \fIerrFilePtr\fR is not NULL, error output from all the commands +in the pipeline will go to a temporary file created by +\fBTcl_CreatePipeline\fR. +A file id to read from that file will be stored at \fI*errFilePtr\fR. +The file will already have been removed, so closing the file +descriptor at \fI*errFilePtr\fR will cause the file to be flushed +completely. +.BE + +.SH DESCRIPTION +.PP +\fBTcl_CreatePipeline\fR processes the \fIargv\fR array and sets +up one or more child processes in a pipeline configuration. +\fBTcl_CreatePipeline\fR handles pipes specified with ``|'', +input redirection specified with ``<'' or ``<<'', and output +redirection specified with ``>''; see the documentation for +the \fBexec\fR command for details on these specifications. +The return value from \fBTcl_CreatePipeline\fR is a count of +the number of child processes created; the process identifiers +for those processes are stored in a \fImalloc\fR-ed array and +a pointer to that array is stored at \fI*pidArrayPtr\fR. +It is the caller's responsibility to free the array when finished +with it. +.PP +If the \fIinPipePtr\fR, \fIoutPipePtr\fR, and \fIerrFilePtr\fR +arguments are NULL then the pipeline's standard input, standard +output, and standard error are taken from the corresponding +streams of the process. Non-NULL values may be specified for +these arguments to use pipes for standard input and standard +output and a file for standard error. \fBTcl_CreatePipeline\fR +will create the requested pipes or file and return file identifiers +that may be used to read or write them. It is the caller's +responsibility to close all of these files when they are no +longer needed. If \fIargv\fR specifies redirection for standard +input or standard output, then pipes will not be created even +if requested by the \fIinPipePtr\fR and \fIoutPipePtr\fR +arguments. +.PP +If an error occurs in \fBTcl_CreatePipeline\fR (e.g. ``|'' or +``<'' was the last argument in \fIargv\fR, or it wasn't possible +to fork off a child), then -1 is returned +and \fIinterp->result\fR is set to an error message. + +.SH "SEE ALSO" +\fBTcl_DetachPids\fR, \fBTcl_ReapDetachedProcs\fR + +.SH KEYWORDS +background, child, detach, fork, process, status, wait diff --git a/vendor/x11iraf/obm/Tcl/doc/CrtTrace.3 b/vendor/x11iraf/obm/Tcl/doc/CrtTrace.3 new file mode 100644 index 00000000..796346d9 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/doc/CrtTrace.3 @@ -0,0 +1,125 @@ +'\" +'\" Copyright (c) 1989-1993 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 +'\" documentation for any purpose, provided that the above copyright +'\" notice and the following two paragraphs appear in all copies. +'\" +'\" 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 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. +'\" +'\" $Header: /user6/ouster/tcl/man/RCS/CrtTrace.3,v 1.8 93/04/01 09:25:26 ouster Exp $ SPRITE (Berkeley) +'\" +.so man.macros +.HS Tcl_CreateTrace tclc +.BS +.SH NAME +Tcl_CreateTrace, Tcl_DeleteTrace \- arrange for command execution to be traced +.SH SYNOPSIS +.nf +\fB#include <tcl.h>\fR +.sp +Tcl_Trace +\fBTcl_CreateTrace\fR(\fIinterp, level, proc, clientData\fR) +.sp +\fBTcl_DeleteTrace\fR(\fIinterp, trace\fR) +.SH ARGUMENTS +.AS Tcl_CmdTraceProc (clientData)() +.AP Tcl_Interp *interp in +Interpreter containing command to be traced or untraced. +.AP int level in +Only commands at or below this nesting level will be traced. 1 means +top-level commands only, 2 means top-level commands or those that are +invoked as immediate consequences of executing top-level commands +(procedure bodies, bracketed commands, etc.) and so on. +.AP Tcl_CmdTraceProc *proc in +Procedure to call for each command that's executed. See below for +details on the calling sequence. +.AP ClientData clientData in +Arbitrary one-word value to pass to \fIproc\fR. +.AP Tcl_Trace trace in +Token for trace to be removed (return value from previous call +to \fBTcl_CreateTrace\fR). +.BE + +.SH DESCRIPTION +.PP +\fBTcl_CreateTrace\fR arranges for command tracing. From now on, \fIproc\fR +will be invoked before Tcl calls command procedures to process +commands in \fIinterp\fR. The return value from +\fBTcl_CreateTrace\fR is a token for the trace, +which may be passed to \fBTcl_DeleteTrace\fR to remove the trace. There may +be many traces in effect simultaneously for the same command interpreter. +.PP +\fIProc\fR should have arguments and result that match the +type \fBTcl_CmdTraceProc\fR: +.nf +.sp +.RS +typedef void Tcl_CmdTraceProc( +.RS +ClientData \fIclientData\fR, +Tcl_Interp *\fIinterp\fR, +int \fIlevel\fR, +char *\fIcommand\fR, +Tcl_CmdProc *\fIcmdProc\fR, +ClientData \fIcmdClientData\fR, +int \fIargc\fR, +char *\fIargv\fR[])); +.sp +.RE +.RE +.fi +The \fIclientData\fP and \fIinterp\fP parameters are +copies of the corresponding arguments given to \fBTcl_CreateTrace\fR. +\fIClientData\fR typically points to an application-specific +data structure that describes what to do when \fIproc\fR +is invoked. \fILevel\fR gives the nesting level of the command +(1 for top-level commands passed to \fBTcl_Eval\fR by the application, +2 for the next-level commands passed to \fBTcl_Eval\fR as part of parsing +or interpreting level-1 commands, and so on). \fICommand\fR +points to a string containing the text of the +command, before any argument substitution. +\fICmdProc\fR contains the address of the command procedure that +will be called to process the command (i.e. the \fIproc\fR argument +of some previous call to \fBTcl_CreateCommand\fR) and \fIcmdClientData\fR +contains the associated client data for \fIcmdProc\fR (the \fIclientData\fR +value passed to \fBTcl_CreateCommand\fR). \fIArgc\fR and \fIargv\fR give +the final argument information that will be passed to \fIcmdProc\fR, after +command, variable, and backslash substitution. +\fIProc\fR must not modify the \fIcommand\fR or \fIargv\fR strings. +.PP +Tracing will only occur for commands at nesting level less than +or equal to the \fIlevel\fR parameter (i.e. the \fIlevel\fR +parameter to \fIproc\fR will always be less than or equal to the +\fIlevel\fR parameter to \fBTcl_CreateTrace\fR). +.PP +Calls to \fIproc\fR will be made by the Tcl parser immediately before +it calls the command procedure for the command (\fIcmdProc\fR). This +occurs after argument parsing and substitution, so tracing for +substituted commands occurs before tracing of the commands +containing the substitutions. If there is a syntax error in a +command, or if there is no command procedure associated with a +command name, then no tracing will occur for that command. If a +string passed to Tcl_Eval contains multiple commands (bracketed, or +on different lines) then multiple calls to \fIproc\fR will occur, +one for each command. The \fIcommand\fR string for each of these +trace calls will reflect only a single command, not the entire string +passed to Tcl_Eval. +.PP +\fBTcl_DeleteTrace\fR removes a trace, so that no future calls will be +made to the procedure associated with the trace. After \fBTcl_DeleteTrace\fR +returns, the caller should never again use the \fItrace\fR token. + +.SH KEYWORDS +command, create, delete, interpreter, trace diff --git a/vendor/x11iraf/obm/Tcl/doc/DString.3 b/vendor/x11iraf/obm/Tcl/doc/DString.3 new file mode 100644 index 00000000..9d72b423 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/doc/DString.3 @@ -0,0 +1,141 @@ +'\" +'\" Copyright (c) 1993 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 +'\" documentation for any purpose, provided that the above copyright +'\" notice and the following two paragraphs appear in all copies. +'\" +'\" 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 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. +'\" +'\" $Header: /user6/ouster/tcl/man/RCS/DString.3,v 1.10 93/08/16 13:24:52 ouster Exp $ SPRITE (Berkeley) +'\" +.so man.macros +.HS Tcl_DStringInit tclc 7.0 +.BS +.SH NAME +.na +Tcl_DStringInit, Tcl_DStringAppend, Tcl_DStringAppendElement, Tcl_DStringStartSublist, Tcl_DStringEndSublist, Tcl_DStringLength, Tcl_DStringValue, Tcl_DStringTrunc, Tcl_DStringFree, Tcl_DStringResult \- manipulate dynamic strings +.ad +.SH SYNOPSIS +.nf +\fB#include <tcl.h>\fR +.sp +\fBTcl_DStringInit\fR(\fIdsPtr\fR) +.sp +char * +\fBTcl_DStringAppend\fR(\fIdsPtr, string, length\fR) +.sp +char * +\fBTcl_DStringAppendElement\fR(\fIdsPtr, string\fR) +.sp +\fBTcl_DStringStartSublist\fR(\fIdsPtr\fR) +.sp +\fBTcl_DStringEndSublist\fR(\fIdsPtr\fR) +.sp +int +\fBTcl_DStringLength\fR(\fIdsPtr\fR) +.sp +char * +\fBTcl_DStringValue\fR(\fIdsPtr\fR) +.sp +\fBTcl_DStringTrunc\fR(\fIdsPtr, newLength\fR) +.sp +\fBTcl_DStringFree\fR(\fIdsPtr\fR) +.sp +\fBTcl_DStringResult\fR(\fIinterp, dsPtr\fR) +.SH ARGUMENTS +.AS Tcl_DString newLength +.AP Tcl_DString *dsPtr in/out +Pointer to structure that is used to manage a dynamic string. +.AP char *string in +Pointer to characters to add to dynamic string. +.AP int length in +Number of characters from string to add to dynamic string. If -1, +add all characters up to null terminating character. +.AP int newLength in +New length for dynamic string, not including null terminating +character. +.BE + +.SH DESCRIPTION +.PP +Dynamic strings provide a mechanism for building up arbitrarily long +strings by gradually appending information. If the dynamic string is +short then there will be no memory allocation overhead; as the string +gets larger, additional space will be allocated as needed. +.PP +\fBTcl_DStringInit\fR initializes a dynamic string to zero length. +The Tcl_DString structure must have been allocated by the caller. +No assumptions are made about the current state of the structure; +anything already in it is discarded. +If the structure has been used previously, \fBTcl_DStringFree\fR should +be called first to free up any memory allocated for the old +string. +.PP +\fBTcl_DStringAppend\fR adds new information to a dynamic string, +allocating more memory for the string if needed. +If \fIlength\fR is less than zero then everything in \fIstring\fR +is appended to the dynamic string; otherwise \fIlength\fR +specifies the number of bytes to append. +\fBTcl_DStringAppend\fR returns a pointer to the characters of +the new string. The string can also be retrieved from the +\fIstring\fR field of the Tcl_DString structure. +.PP +\fBTcl_DStringAppendElement\fR is similar to \fBTcl_DStringAppend\fR +except that it doesn't take a \fIlength\fR argument (it appends +all of \fIstring\fR) and it converts the string to a proper list element +before appending. +\fBTcl_DStringAppendElement\fR adds a separator space before the +new list element unless the new list element is the first in a +list or sub-list (i.e. either the current string is empty, or it +contains the single character ``{'', or the last two characters of +the current string are `` {''). +\fBTcl_DStringAppendElement\fR returns a pointer to the +characters of the new string. +.PP +\fBTcl_DStringStartSublist\fR and \fBTcl_DStringEndSublist\fR can be +used to create nested lists. +To append a list element that is itself a sublist, first +call \fBTcl_DStringStartSublist\fR, then call \fBTcl_DStringAppendElement\fR +for each of the elements in the sublist, then call +\fBTcl_DStringEndSublist\fR to end the sublist. +\fBTcl_DStringStartSublist\fR appends a space character if needed, +followed by an open brace; \fBTcl_DStringAppendElement\fR appends +a close brace. +Lists can be nested to any depth. +.PP +\fBTcl_DStringLength\fR is a macro that returns the current length +of a dynamic string (not including the terminating null character). +\fBTcl_DStringValue\fR is a macro that returns a pointer to the +current contents of a dynamic string. +.PP +\fBTcl_DStringTrunc\fR truncates a dynamic string to a given length. +It has no effect if the string was already smaller than \fInewLength\fR. +This procedure does not free up the string's storage space, even +if the string is truncated to zero length, so \fBTcl_DStringFree\fR +will still need to be called. +.PP +\fBTcl_DStringFree\fR should be called when you're finished using +the string. It frees up any memory that was allocated for the string +and reinitializes the string's value to an empty string. +.PP +\fBTcl_DStringResult\fR sets the result of \fIinterp\fR to the value of +the dynamic string given by \fIdsPtr\fR. It does this by moving +a pointer from \fIdsPtr\fR to \fIinterp->result\fR. +This saves the cost of allocating new memory and copying the string. +\fBTcl_DStringResult\fR also reinitializes the dynamic string to +an empty string. + +.SH KEYWORDS +append, dynamic string, free, result diff --git a/vendor/x11iraf/obm/Tcl/doc/DetachPids.3 b/vendor/x11iraf/obm/Tcl/doc/DetachPids.3 new file mode 100644 index 00000000..4862d92d --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/doc/DetachPids.3 @@ -0,0 +1,79 @@ +'\" +'\" Copyright (c) 1989-1993 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 +'\" documentation for any purpose, provided that the above copyright +'\" notice and the following two paragraphs appear in all copies. +'\" +'\" 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 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. +'\" +'\" $Header: /user6/ouster/tcl/man/RCS/DetachPids.3,v 1.10 93/09/09 10:53:24 ouster Exp $ SPRITE (Berkeley) +'\" +.so man.macros +.HS Tcl_DetachPids tclc +.BS +.SH NAME +Tcl_DetachPids, Tcl_ReapDetachedProcs \- manage child processes in background +.SH SYNOPSIS +.nf +\fB#include <tcl.h>\fR +.sp +\fBTcl_DetachPids\fR(\fInumPids, pidPtr\fR) +.sp +.VS +\fBTcl_ReapDetachedProcs\fR() +.VE +.SH ARGUMENTS +.AS int *statusPtr +.AP int numPids in +Number of process ids contained in the array pointed to by \fIpidPtr\fR. +.AP int *pidPtr in +Address of array containing \fInumPids\fR process ids. +.BE + +.SH DESCRIPTION +.PP +.VS +\fBTcl_DetachPids\fR and \fBTcl_ReapDetachedProcs\fR provide a +mechanism for managing subprocesses that are running in background. +These procedures are needed because the parent of a process must +eventually invoke the \fBwaitpid\fR kernel call (or one of a few other +similar kernel calls) to wait for the child to exit. Until the +parent waits for the child, the child's state cannot be completely +reclaimed by the system. If a parent continually creates children +and doesn't wait on them, the system's process table will eventually +overflow, even if all the children have exited. +.PP +\fBTcl_DetachPids\fR may be called to ask Tcl to take responsibility +for one or more processes whose process ids are contained in the +\fIpidPtr\fR array passed as argument. The caller presumably +has started these processes running in background and doesn't +want to have to deal with them again. +.PP +\fBTcl_ReapDetachedProcs\fR invokes the \fBwaitpid\fR kernel call +on each of the background processes so that its state can be cleaned +up if it has exited. If the process hasn't exited yet, +\fBTcl_ReapDetachedProcs\fR doesn't wait for it to exit; it will check again +the next time it is invoked. +Tcl automatically calls \fBTcl_ReapDetachedProcs\fR each time the +\fBexec\fR command is executed, so in most cases it isn't necessary +for any code outside of Tcl to invoke \fBTcl_ReapDetachedProcs\fR. +However, if you call \fBTcl_DetachPids\fR in situations where the +\fBexec\fR command may never get executed, you may wish to call +\fBTcl_ReapDetachedProcs\fR from time to time so that background +processes can be cleaned up. +.VE + +.SH KEYWORDS +background, child, detach, process, wait diff --git a/vendor/x11iraf/obm/Tcl/doc/EnterFile.3 b/vendor/x11iraf/obm/Tcl/doc/EnterFile.3 new file mode 100644 index 00000000..12f15299 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/doc/EnterFile.3 @@ -0,0 +1,98 @@ +'\" +'\" Copyright (c) 1989-1993 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 +'\" documentation for any purpose, provided that the above copyright +'\" notice and the following two paragraphs appear in all copies. +'\" +'\" 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 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. +'\" +'\" $Header: /user6/ouster/tcl/man/RCS/EnterFile.3,v 1.4 93/08/27 13:20:42 ouster Exp $ SPRITE (Berkeley) +'\" +.so man.macros +.HS Tcl_EnterFile tclc 7.0 +.BS +.SH NAME +Tcl_EnterFile, Tcl_GetOpenFile, Tcl_FilePermissions \- manipulate the table of open files +.SH SYNOPSIS +.nf +\fB#include <tcl.h>\fR +.sp +\fBTcl_EnterFile\fR(\fIinterp, file, permissions\fR) +.sp +int +\fBTcl_GetOpenFile\fR(\fIinterp, string, write, checkUsage, filePtr\fR) +.sp +int +\fBTcl_FilePermissions(\fIfile\fR) +.SH ARGUMENTS +.AS Tcl_Interp checkUsage +.AP Tcl_Interp *interp in +Tcl interpreter from which file is to be accessed. +.AP FILE *file in +Handle for file that is to become accessible in \fIinterp\fR. +.AP int permissions in +OR-ed combination of TCL_FILE_READABLE and TCL_FILE_WRITABLE; +indicates whether \fIfile\fR was opened for reading or writing or both. +.AP char *string in +String identifying file, such as \fBstdin\fR or \fBfile4\fR. +.AP int write in +Non-zero means the file will be used for writing, zero means it will +be used for reading. +.AP int checkUsage in +If non-zero, then an error will be generated if the file wasn't opened +for the access indicated by \fIwrite\fR. +.AP FILE **filePtr out +Points to word in which to store pointer to FILE structure for +the file given by \fIstring\fR. +.BE + +.SH DESCRIPTION +.PP +These procedures provide access to Tcl's file naming mechanism. +\fBTcl_EnterFile\fR enters an open file into Tcl's file table so +that it can be accessed using Tcl commands like \fBgets\fR, +\fBputs\fR, \fBseek\fR, and \fBclose\fR. +It returns in \fIinterp->result\fR an identifier such as \fBfile4\fR +that can be used to refer to the file in subsequent Tcl commands. +\fBTcl_EnterFile\fR is typically used to implement new Tcl commands +that open sockets, pipes, or other kinds of files not already supported +by the built-in commands. +.PP +\fBTcl_GetOpenFile\fR takes as argument a file identifier of the form +returned by the \fBopen\fR command or \fBTcl_EnterFile\fR and +returns at \fI*filePtr\fR a pointer to the FILE structure for +the file. +The \fIwrite\fR argument indicates whether the FILE pointer will +be used for reading or writing. +In some cases, such as a file that connects to a pipeline of +subprocesses, different FILE pointers will be returned for reading +and writing. +\fBTcl_GetOpenFile\fR normally returns TCL_OK. +If an error occurs in \fBTcl_GetOpenFile\fR (e.g. \fIstring\fR didn't +make any sense or \fIcheckUsage\fR was set and the file wasn't opened +for the access specified by \fIwrite\fR) then TCL_ERROR is returned +and \fIinterp->result\fR will contain an error message. +If \fIcheckUsage\fR is zero and the file wasn't opened for the +access specified by \fIwrite\fR, then the FILE pointer returned +at \fI*filePtr\fR may not correspond to \fIwrite\fR. +.PP +\fBTcl_FilePermissions\fR returns an OR-ed combination of the +mask bits TCL_FILE_READABLE and TCL_FILE_WRITABLE; these indicate +whether the given file was opened for reading or writing or both. +If \fIfile\fR does not refer to a file in Tcl's file table then +\-1 is returned. + +.SH KEYWORDS +file table, permissions, pipeline, read, write diff --git a/vendor/x11iraf/obm/Tcl/doc/Eval.3 b/vendor/x11iraf/obm/Tcl/doc/Eval.3 new file mode 100644 index 00000000..db2cbf40 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/doc/Eval.3 @@ -0,0 +1,119 @@ +'\" +'\" Copyright (c) 1989-1993 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 +'\" documentation for any purpose, provided that the above copyright +'\" notice and the following two paragraphs appear in all copies. +'\" +'\" 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 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. +'\" +'\" $Header: /user6/ouster/tcl/man/RCS/Eval.3,v 1.13 93/04/03 16:40:04 ouster Exp $ SPRITE (Berkeley) +'\" +.so man.macros +.HS Tcl_Eval tclc 7.0 +.BS +.SH NAME +Tcl_Eval, Tcl_VarEval, Tcl_EvalFile, Tcl_GlobalEval \- execute Tcl commands +.SH SYNOPSIS +.nf +\fB#include <tcl.h>\fR +.sp +int +.VS +\fBTcl_Eval\fR(\fIinterp, cmd\fR) +.VE +.sp +int +\fBTcl_VarEval\fR(\fIinterp, string, string, ... \fB(char *) NULL\fR) +.sp +int +\fBTcl_EvalFile\fR(\fIinterp, fileName\fR) +.sp +int +\fBTcl_GlobalEval\fR(\fIinterp, cmd\fR) +.SH ARGUMENTS +.AS Tcl_Interp **termPtr; +.AP Tcl_Interp *interp in +Interpreter in which to execute the command. String result will be +stored in \fIinterp->result\fR. +.AP char *cmd in +Command (or sequence of commands) to execute. Must be in writable +memory (\fBTcl_Eval\fR makes temporary modifications to the command). +.AP char *string in +String forming part of Tcl command. +.AP char *fileName in +Name of file containing Tcl command string. +.BE + +.SH DESCRIPTION +.PP +All four of these procedures execute Tcl commands. +\fBTcl_Eval\fR is the core procedure: it parses commands +from \fIcmd\fR and executes them in +.VS +order until either an error occurs or it reaches the end of the string. +.VE +The return value from \fBTcl_Eval\fR is one +of the Tcl return codes \fBTCL_OK\fR, \fBTCL_ERROR\fR, \fBTCL_RETURN\fR, \fBTCL_BREAK\fR, or +\fBTCL_CONTINUE\fR, and \fIinterp->result\fR will point to +a string with additional information (result value or error message). +This return information corresponds to the last command executed from +\fIcmd\fR. +.PP +\fBTcl_VarEval\fR takes any number of string arguments +of any length, concatenates +them into a single string, then calls \fBTcl_Eval\fR to +execute that string as a Tcl command. +It returns the result of the command and also modifies +\fIinterp->result\fR in the usual fashion for Tcl commands. The +last argument to \fBTcl_VarEval\fR must be NULL to indicate the end +of arguments. +.PP +\fBTcl_EvalFile\fR reads the file given by \fIfileName\fR and evaluates +its contents as a Tcl command by calling \fBTcl_Eval\fR. It returns +a standard Tcl result that reflects the result of evaluating the +file. +If the file couldn't be read then a Tcl error is returned to describe +why the file couldn't be read. +.PP +\fBTcl_GlobalEval\fR is similar to \fBTcl_Eval\fR except that it +processes the command at global level. +This means that the variable context for the command consists of +global variables only (it ignores any Tcl procedure that is active). +This produces an effect similar to the Tcl command ``\fBuplevel 0\fR''. +.PP +During the processing of a Tcl command it is legal to make nested +calls to evaluate other commands (this is how conditionals, loops, +and procedures are implemented). +If a code other than +\fBTCL_OK\fR is returned from a nested \fBTcl_Eval\fR invocation, then the +caller should normally return immediately, passing that same +return code back to its caller, and so on until the top-level application is +reached. A few commands, like \fBfor\fR, will check for certain +return codes, like \fBTCL_BREAK\fR and \fBTCL_CONTINUE\fR, and process them +specially without returning. +.PP +\fBTcl_Eval\fR keeps track of how many nested Tcl_Eval invocations are +in progress for \fIinterp\fR. +If a code of \fBTCL_RETURN\fR, \fBTCL_BREAK\fR, or \fBTCL_CONTINUE\fR is +about to be returned from the topmost \fBTcl_Eval\fR invocation for +\fIinterp\fR, then \fBTcl_Eval\fR converts the return code to \fBTCL_ERROR\fR +and sets \fIinterp->result\fR to point to an error message indicating that +the \fBreturn\fR, \fBbreak\fR, or \fBcontinue\fR command was +invoked in an inappropriate place. This means that top-level +applications should never see a return code from \fBTcl_Eval\fR other then +\fBTCL_OK\fR or \fBTCL_ERROR\fR. + +.SH KEYWORDS +command, execute, file, global, interpreter, variable diff --git a/vendor/x11iraf/obm/Tcl/doc/ExprLong.3 b/vendor/x11iraf/obm/Tcl/doc/ExprLong.3 new file mode 100644 index 00000000..a043347b --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/doc/ExprLong.3 @@ -0,0 +1,119 @@ +'\" +'\" Copyright (c) 1989-1993 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 +'\" documentation for any purpose, provided that the above copyright +'\" notice and the following two paragraphs appear in all copies. +'\" +'\" 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 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. +'\" +'\" $Header: /user6/ouster/tcl/man/RCS/ExprLong.3,v 1.11 93/04/17 15:31:16 ouster Exp $ SPRITE (Berkeley) +'\" +.so man.macros +.HS Tcl_ExprLong tclc 7.0 +.BS +.SH NAME +Tcl_ExprLong, Tcl_ExprDouble, Tcl_ExprBool, Tcl_ExprString \- evaluate an expression +.SH SYNOPSIS +.nf +\fB#include <tcl.h>\fR +.sp +int +\fBTcl_ExprLong\fR(\fIinterp, string, longPtr\fR) +.sp +int +\fBTcl_ExprDouble\fR(\fIinterp, string, doublePtr\fR) +.sp +int +\fBTcl_ExprBoolean\fR(\fIinterp, string, booleanPtr\fR) +.sp +int +\fBTcl_ExprString\fR(\fIinterp, string\fR) +.SH ARGUMENTS +.AS Tcl_Interp *booleanPtr +.AP Tcl_Interp *interp in +Interpreter in whose context to evaluate \fIstring\fR. +.AP char *string in +Expression to be evaluated. Must be in writable memory (the expression +parser makes temporary modifications to the string during parsing, which +it undoes before returning). +.AP long *longPtr out +Pointer to location in which to store the integer value of the +expression. +.AP int *doublePtr out +Pointer to location in which to store the floating-point value of the +expression. +.AP int *booleanPtr out +Pointer to location in which to store the 0/1 boolean value of the +expression. +.BE + +.SH DESCRIPTION +.PP +These four procedures all evaluate an expression, returning +the result in one of four different forms. +The expression is given by the \fIstring\fR argument, and it +can have any of the forms accepted by the \fBexpr\fR command. +The \fIinterp\fR argument refers to an interpreter used to +evaluate the expression (e.g. for variables and nested Tcl +commands) and to return error information. \fIInterp->result\fR +is assumed to be initialized in the standard fashion when any +of the procedures are invoked. +.PP +For all of these procedures the return value is a standard +Tcl result: \fBTCL_OK\fR means the expression was succesfully +evaluated, and \fBTCL_ERROR\fR means that an error occurred while +evaluating the expression. If \fBTCL_ERROR\fR is returned then +\fIinterp->result\fR will hold a message describing the error. +If an error occurs while executing a Tcl command embedded in +the expression then that error will be returned. +.PP +If the expression is successfully evaluated, then its value is +returned in one of four forms, depending on which procedure +is invoked. +\fBTcl_ExprLong\fR stores an integer value at \fI*longPtr\fR. +If the expression's actual value is a floating-point number, +then it is truncated to an integer. +If the expression's actual value is a non-numeric string then +an error is returned. +.PP +\fBTcl_ExprDouble\fR stores a floating-point value at \fI*doublePtr\fR. +If the expression's actual value is an integer, it is converted to +floating-point. +If the expression's actual value is a non-numeric string then +an error is returned. +.PP +\fBTcl_ExprBoolean\fR stores a 0/1 integer value at \fI*booleanPtr\fR. +If the expression's actual value is an integer or floating-point +number, then \fBTcl_ExprBoolean\fR stores 0 at \fI*booleanPtr\fR if +the value was zero and 1 otherwise. +.VS +If the expression's actual value is a non-numeric string then +it must be one of the values accepted by \fBTcl_GetBoolean\fR, +such as ``yes'' or ``no'', or else an error occurs. +.VE +.PP +\fBTcl_ExprString\fR returns the value of the expression as a +string stored in \fIinterp->result\fR. +.VS +If the expression's actual value is an integer +then \fBTcl_ExprString\fR converts it to a string using \fBsprintf\fR +with a ``%d'' converter. +If the expression's actual value is a floating-point +number, then \fBTcl_ExprString\fR calls \fBTcl_PrintDouble\fR +to convert it to a string. +.VE + +.SH KEYWORDS +boolean, double, evaluate, expression, integer, string diff --git a/vendor/x11iraf/obm/Tcl/doc/GetInt.3 b/vendor/x11iraf/obm/Tcl/doc/GetInt.3 new file mode 100644 index 00000000..b3cf91d5 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/doc/GetInt.3 @@ -0,0 +1,94 @@ +'\" +'\" Copyright (c) 1989-1993 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 +'\" documentation for any purpose, provided that the above copyright +'\" notice and the following two paragraphs appear in all copies. +'\" +'\" 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 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. +'\" +'\" $Header: /user6/ouster/tcl/man/RCS/GetInt.3,v 1.8 93/04/01 09:25:29 ouster Exp $ SPRITE (Berkeley) +'\" +.so man.macros +.HS Tcl_GetInt tclc +.BS +.SH NAME +Tcl_GetInt, Tcl_GetDouble, Tcl_GetBoolean \- convert from string to integer, double, or boolean +.SH SYNOPSIS +.nf +\fB#include <tcl.h>\fR +.sp +int +\fBTcl_GetInt\fR(\fIinterp, string, intPtr\fR) +.sp +int +\fBTcl_GetDouble\fR(\fIinterp, string, doublePtr\fR) +.sp +int +\fBTcl_GetBoolean\fR(\fIinterp, string, boolPtr\fR) +.SH ARGUMENTS +.AS Tcl_Interp *doublePtr +.AP Tcl_Interp *interp in +Interpreter to use for error reporting. +.AP char *string in +Textual value to be converted. +.AP int *intPtr out +Points to place to store integer value converted from \fIstring\fR. +.AP double *doublePtr out +Points to place to store double-precision floating-point +value converted from \fIstring\fR. +.AP int *boolPtr out +Points to place to store boolean value (0 or 1) converted from \fIstring\fR. +.BE + +.SH DESCRIPTION +.PP +These procedures convert from strings to integers or double-precision +floating-point values or booleans (represented as 0- or 1-valued +integers). Each of the procedures takes a \fIstring\fR argument, +converts it to an internal form of a particular type, and stores +the converted value at the location indicated by the procedure's +third argument. If all goes well, each of the procedures returns +TCL_OK. If \fIstring\fR doesn't have the proper syntax for the +desired type then TCL_ERROR is returned, an error message is left +in \fIinterp->result\fR, and nothing is stored at *\fIintPtr\fR +or *\fIdoublePtr\fR or *\fIboolPtr\fR. +.PP +\fBTcl_GetInt\fR expects \fIstring\fR to consist of a collection +of integer digits, optionally signed and optionally preceded by +white space. If the first two characters of \fIstring\fR are ``0x'' +then \fIstring\fR is expected to be in hexadecimal form; otherwise, +if the first character of \fIstring\fR is ``0'' then \fIstring\fR +is expected to be in octal form; otherwise, \fIstring\fR is +expected to be in decimal form. +.PP +\fBTcl_GetDouble\fR expects \fIstring\fR to consist of a floating-point +number, which is: white space; a sign; a sequence of digits; a +decimal point; a sequence of digits; the letter ``e''; and a +signed decimal exponent. Any of the fields may be omitted, except that +the digits either before or after the decimal point must be present +and if the ``e'' is present then it must be followed by the +exponent number. +.PP +\fBTcl_GetBoolean\fR expects \fIstring\fR to specify a boolean +value. If \fIstring\fR is any of \fB0\fR, \fBfalse\fR, +\fBno\fR, or \fBoff\fR, then \fBTcl_GetBoolean\fR stores a zero +value at \fI*boolPtr\fR. +If \fIstring\fR is any of \fB1\fR, \fBtrue\fR, \fByes\fR, or \fBon\fR, +then 1 is stored at \fI*boolPtr\fR. +Any of these values may be abbreviated, and upper-case spellings +are also acceptable. + +.SH KEYWORDS +boolean, conversion, double, floating-point, integer diff --git a/vendor/x11iraf/obm/Tcl/doc/Hash.3 b/vendor/x11iraf/obm/Tcl/doc/Hash.3 new file mode 100644 index 00000000..fec89035 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/doc/Hash.3 @@ -0,0 +1,222 @@ +'\" +'\" Copyright (c) 1989-1993 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 +'\" documentation for any purpose, provided that the above copyright +'\" notice and the following two paragraphs appear in all copies. +'\" +'\" 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 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. +'\" +'\" $Header: /user6/ouster/tcl/man/RCS/Hash.3,v 1.9 93/07/23 08:30:53 ouster Exp $ SPRITE (Berkeley) +'\" +.so man.macros +.HS Tcl_Hash tclc +.BS +.SH NAME +.na +Tcl_InitHashTable, Tcl_DeleteHashTable, Tcl_CreateHashEntry, Tcl_DeleteHashEntry, Tcl_FindHashEntry, Tcl_GetHashValue, Tcl_SetHashValue, Tcl_GetHashKey, Tcl_FirstHashEntry, Tcl_NextHashEntry, Tcl_HashStats \- procedures to manage hash tables +.SH SYNOPSIS +.nf +\fB#include <tcl.h>\fR +.sp +\fBTcl_InitHashTable\fR(\fItablePtr, keyType\fR) +.sp +\fBTcl_DeleteHashTable\fR(\fItablePtr\fR) +.sp +Tcl_HashEntry * +\fBTcl_CreateHashEntry\fR(\fItablePtr, key, newPtr\fR) +.sp +\fBTcl_DeleteHashEntry\fR(\fIentryPtr\fR) +.sp +Tcl_HashEntry * +\fBTcl_FindHashEntry\fR(\fItablePtr, key\fR) +.sp +ClientData +\fBTcl_GetHashValue\fR(\fIentryPtr\fR) +.sp +\fBTcl_SetHashValue\fR(\fIentryPtr, value\fR) +.sp +char * +\fBTcl_GetHashKey\fR(\fItablePtr, entryPtr\fR) +.sp +Tcl_HashEntry * +\fBTcl_FirstHashEntry\fR(\fItablePtr, searchPtr\fR) +.sp +Tcl_HashEntry * +\fBTcl_NextHashEntry\fR(\fIsearchPtr\fR) +.sp +char * +\fBTcl_HashStats\fR(\fItablePtr\fR) +.SH ARGUMENTS +.AS Tcl_HashSearch *searchPtr +.AP Tcl_HashTable *tablePtr in +Address of hash table structure (for all procedures but +\fBTcl_InitHashTable\fR, this must have been initialized by +previous call to \fBTcl_InitHashTable\fR). +.AP int keyType in +Kind of keys to use for new hash table. Must be either +TCL_STRING_KEYS, TCL_ONE_WORD_KEYS, or an integer value +greater than 1. +.AP char *key in +Key to use for probe into table. Exact form depends on +\fIkeyType\fR used to create table. +.AP int *newPtr out +The word at \fI*newPtr\fR is set to 1 if a new entry was created +and 0 if there was already an entry for \fIkey\fR. +.AP Tcl_HashEntry *entryPtr in +Pointer to hash table entry. +.AP ClientData value in +New value to assign to hash table entry. Need not have type +ClientData, but must fit in same space as ClientData. +.AP Tcl_HashSearch *searchPtr in +Pointer to record to use to keep track of progress in enumerating +all the entries in a hash table. +.BE + +.SH DESCRIPTION +.PP +A hash table consists of zero or more entries, each consisting of +a key and a value. +Given the key for an entry, the hashing routines can very quickly +locate the entry, and hence its value. +There may be at most one entry in a hash table with a +particular key, but many entries may have the same value. +Keys can take one of three forms: strings, +one-word values, or integer arrays. +All of the keys in a given table have the same form, which is +specified when the table is initialized. +.PP +The value of a hash table entry can be anything that fits in +the same space as a ``char *'' pointer. +Values for hash table entries are managed entirely by clients, +not by the hash module itself. +Typically each entry's value is a pointer to a data structure +managed by client code. +.PP +Hash tables grow gracefully as the number of entries increases, +so that there are always less than three entries per hash bucket, +on average. +This allows for fast lookups regardless of the number of entries +in a table. +.PP +\fBTcl_InitHashTable\fR initializes a structure that describes +a new hash table. +The space for the structure is provided by the caller, not by +the hash module. +The value of \fIkeyType\fR indicates what kinds of keys will +be used for all entries in the table. \fIKeyType\fR must have +one of the following values: +.IP \fBTCL_STRING_KEYS\fR 25 +Keys are null-terminated ASCII strings. +They are passed to hashing routines using the address of the +first character of the string. +.IP \fBTCL_ONE_WORD_KEYS\fR 25 +Keys are single-word values; they are passed to hashing routines +and stored in hash table entries as ``char *'' values. +The pointer value is the key; it need not (and usually doesn't) +actually point to a string. +.IP \fIother\fR 25 +If \fIkeyType\fR is not TCL_STRING_KEYS or TCL_ONE_WORD_KEYS, +then it must be an integer value greater than 1. +In this case the keys will be arrays of ``int'' values, where +\fIkeyType\fR gives the number of ints in each key. +This allows structures to be used as keys. +All keys must have the same size. +Array keys are passed into hashing functions using the address +of the first int in the array. +.PP +\fBTcl_DeleteHashTable\fR deletes all of the entries in a hash +table and frees up the memory associated with the table's +bucket array and entries. +It does not free the actual table structure (pointed to +by \fItablePtr\fR), since that memory is assumed to be managed +by the client. +\fBTcl_DeleteHashTable\fR also does not free or otherwise +manipulate the values of the hash table entries. +If the entry values point to dynamically-allocated memory, then +it is the client's responsibility to free these structures +before deleting the table. +.PP +\fBTcl_CreateHashEntry\fR locates the entry corresponding to a +particular key, creating a new entry in the table if there +wasn't already one with the given key. +If an entry already existed with the given key then \fI*newPtr\fR +is set to zero. +If a new entry was created, then \fI*newPtr\fR is set to a non-zero +value and the value of the new entry will be set to zero. +The return value from \fBTcl_CreateHashEntry\fR is a pointer to +the entry, which may be used to retrieve and modify the entry's +value or to delete the entry from the table. +.PP +\fBTcl_DeleteHashEntry\fR will remove an existing entry from a +table. +The memory associated with the entry itself will be freed, but +the client is responsible for any cleanup associated with the +entry's value, such as freeing a structure that it points to. +.PP +\fBTcl_FindHashEntry\fR is similar to \fBTcl_CreateHashEntry\fR +except that it doesn't create a new entry if the key doesn't exist; +instead, it returns NULL as result. +.PP +\fBTcl_GetHashValue\fR and \fBTcl_SetHashValue\fR are used to +read and write an entry's value, respectively. +Values are stored and retrieved as type ``ClientData'', which is +large enough to hold a pointer value. On almost all machines this is +large enough to hold an integer value too. +.PP +\fBTcl_GetHashKey\fR returns the key for a given hash table entry, +either as a pointer to a string, a one-word (``char *'') key, or +as a pointer to the first word of an array of integers, depending +on the \fIkeyType\fR used to create a hash table. +In all cases \fBTcl_GetHashKey\fR returns a result with type +``char *''. +When the key is a string or array, the result of \fBTcl_GetHashKey\fR +points to information in the table entry; this information will +remain valid until the entry is deleted or its table is deleted. +.PP +\fBTcl_FirstHashEntry\fR and \fBTcl_NextHashEntry\fR may be used +to scan all of the entries in a hash table. +A structure of type ``Tcl_HashSearch'', provided by the client, +is used to keep track of progress through the table. +\fBTcl_FirstHashEntry\fR initializes the search record and +returns the first entry in the table (or NULL if the table is +empty). +Each susequent call to \fBTcl_NextHashEntry\fR returns the +next entry in the table or +NULL if the end of the table has been reached. +A call to \fBTcl_FirstHashEntry\fR followed by calls to +\fBTcl_NextHashEntry\fR will return each of the entries in +the table exactly once, in an arbitrary order. +It is unadvisable to modify the structure of the table, e.g. +by creating or deleting entries, while the search is in +progress. +.PP +\fBTcl_HashStats\fR returns a dynamically-allocated string with +overall information about a hash table, such as the number of +entries it contains, the number of buckets in its hash array, +and the utilization of the buckets. +It is the caller's responsibility to free the result string +by passing it to \fBfree\fR. +.PP +The header file \fBtcl.h\fR defines the actual data structures +used to implement hash tables. +This is necessary so that clients can allocate Tcl_HashTable +structures and so that macros can be used to read and write +the values of entries. +However, users of the hashing routines should never refer directly +to any of the fields of any of the hash-related data structures; +use the procedures and macros defined here. + +.SH KEYWORDS +hash table, key, lookup, search, value diff --git a/vendor/x11iraf/obm/Tcl/doc/Interp.3 b/vendor/x11iraf/obm/Tcl/doc/Interp.3 new file mode 100644 index 00000000..a93cfccb --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/doc/Interp.3 @@ -0,0 +1,132 @@ +'\" +'\" Copyright (c) 1989-1993 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 +'\" documentation for any purpose, provided that the above copyright +'\" notice and the following two paragraphs appear in all copies. +'\" +'\" 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 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. +'\" +'\" $Header: /user6/ouster/tcl/man/RCS/Interp.3,v 1.10 93/04/01 09:25:32 ouster Exp $ SPRITE (Berkeley) +'\" +.so man.macros +.HS Tcl_Interp tclc +.BS +.SH NAME +Tcl_Interp \- client-visible fields of interpreter structures +.SH SYNOPSIS +.nf +\fB#include <tcl.h>\fR +.sp +typedef struct { + char *\fIresult\fR; + Tcl_FreeProc *\fIfreeProc\fR; + int \fIerrorLine\fR; +} Tcl_Interp; + +typedef void Tcl_FreeProc(char *\fIblockPtr\fR); +.BE + +.SH DESCRIPTION +.PP +The \fBTcl_CreateInterp\fR procedure returns a pointer to a Tcl_Interp +structure. This pointer is then passed into other Tcl procedures +to process commands in the interpreter and perform other operations +on the interpreter. Interpreter structures contain many many fields +that are used by Tcl, but only three that may be accessed by +clients: \fIresult\fR, \fIfreeProc\fR, and \fIerrorLine\fR. +.PP +The \fIresult\fR and \fIfreeProc\fR fields are used to return +results or error messages from commands. +This information is returned by command procedures back to \fBTcl_Eval\fR, +and by \fBTcl_Eval\fR back to its callers. +The \fIresult\fR field points to the string that represents the +result or error message, and the \fIfreeProc\fR field tells how +to dispose of the storage for the string when it isn't needed anymore. +The easiest way for command procedures to manipulate these +fields is to call procedures like \fBTcl_SetResult\fR +or \fBTcl_AppendResult\fR; they +will hide all the details of managing the fields. +The description below is for those procedures that manipulate the +fields directly. +.PP +Whenever a command procedure returns, it must ensure +that the \fIresult\fR field of its interpreter points to the string +being returned by the command. +The \fIresult\fR field must always point to a valid string. +If a command wishes to return no result then \fIinterp->result\fR +should point to an empty string. +Normally, results are assumed to be statically allocated, +which means that the contents will not change before the next time +\fBTcl_Eval\fR is called or some other command procedure is invoked. +In this case, the \fIfreeProc\fR field must be zero. +Alternatively, a command procedure may dynamically +allocate its return value (e.g. using \fBmalloc\fR) +and store a pointer to it in \fIinterp->result\fR. +In this case, the command procedure must also set \fIinterp->freeProc\fR +to the address of a procedure that can free the value (usually \fBfree\fR). +If \fIinterp->freeProc\fR is non-zero, then Tcl will call \fIfreeProc\fR +to free the space pointed to by \fIinterp->result\fR before it +invokes the next command. +If a client procedure overwrites \fIinterp->result\fR when +\fIinterp->freeProc\fR is non-zero, then it is responsible for calling +\fIfreeProc\fR to free the old \fIinterp->result\fR (the \fBTcl_FreeResult\fR +macro should be used for this purpose). +.PP +\fIFreeProc\fR should have arguments and result that match the +\fBTcl_FreeProc\fR declaration above: it receives a single +argument which is a pointer to the result value to free. +In most applications \fBfree\fR is the only non-zero value ever +used for \fIfreeProc\fR. +However, an application may store a different procedure address +in \fIfreeProc\fR in order to use an alternate memory allocator +or in order to do other cleanup when the result memory is freed. +.PP +As part of processing each command, \fBTcl_Eval\fR initializes +\fIinterp->result\fR +and \fIinterp->freeProc\fR just before calling the command procedure for +the command. The \fIfreeProc\fR field will be initialized to zero, +and \fIinterp->result\fR will point to an empty string. Commands that +do not return any value can simply leave the fields alone. +Furthermore, the empty string pointed to by \fIresult\fR is actually +part of an array of \fBTCL_RESULT_SIZE\fR characters (approximately 200). +If a command wishes to return a short string, it can simply copy +it to the area pointed to by \fIinterp->result\fR. Or, it can use +the sprintf procedure to generate a short result string at the location +pointed to by \fIinterp->result\fR. +.PP +It is a general convention in Tcl-based applications that the result +of an interpreter is normally in the initialized state described +in the previous paragraph. +Procedures that manipulate an interpreter's result (e.g. by +returning an error) will generally assume that the result +has been initialized when the procedure is called. +If such a procedure is to be called after the result has been +changed, then \fBTcl_ResetResult\fR should be called first to +reset the result to its initialized state. +.PP +The \fIerrorLine\fR +field is valid only after \fBTcl_Eval\fR returns +a \fBTCL_ERROR\fR return code. In this situation the \fIerrorLine\fR +field identifies the line number of the command being executed when +the error occurred. The line numbers are relative to the command +being executed: 1 means the first line of the command passed to +\fBTcl_Eval\fR, 2 means the second line, and so on. +The \fIerrorLine\fR field is typically used in conjunction with +\fBTcl_AddErrorInfo\fR to report information about where an error +occurred. +\fIErrorLine\fR should not normally be modified except by \fBTcl_Eval\fR. + +.SH KEYWORDS +free, initialized, interpreter, malloc, result diff --git a/vendor/x11iraf/obm/Tcl/doc/LinkVar.3 b/vendor/x11iraf/obm/Tcl/doc/LinkVar.3 new file mode 100644 index 00000000..f44c96c6 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/doc/LinkVar.3 @@ -0,0 +1,113 @@ +'\" +'\" Copyright (c) 1993 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 +'\" documentation for any purpose, provided that the above copyright +'\" notice and the following two paragraphs appear in all copies. +'\" +'\" 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 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. +'\" +'\" $Header: /user6/ouster/tcl/man/RCS/LinkVar.3,v 1.4 93/07/28 15:18:56 ouster Exp $ SPRITE (Berkeley) +'\" +.so man.macros +.HS Tcl_LinkVar tclc 7.0 +.BS +.SH NAME +.na +Tcl_LinkVar, Tcl_UnlinkVar \- link Tcl variable to C variable +.ad +.SH SYNOPSIS +.nf +\fB#include <tcl.h>\fR +.sp +int +\fBTcl_LinkVar\fR(\fIinterp, varName, addr, type\fR) +.sp +\fBTcl_UnlinkVar\fR(\fIinterp, varName\fR) +.SH ARGUMENTS +.AS Tcl_Interp writable +.AP Tcl_Interp *interp in +Interpreter that contains \fIvarName\fR. +Also used by \fBTcl_LinkVar\fR to return error messages. +.AP char *varName in +Name of global variable. +.AP char *addr in +Address of C variable that is to be linked to \fIvarName\fR. +.AP int type in +.na +Type of C variable. Must be one of TCL_LINK_INT, TCL_LINK_DOUBLE, +TCL_LINK_BOOLEAN, or TCL_LINK_STRING, optionally OR'ed with +TCL_LINK_READ_ONLY to make Tcl variable read-only. +.ad +.BE + +.SH DESCRIPTION +.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. +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. +\fBTcl_LinkVar\fR normally returns TCL_OK; if an error occurs +while setting up the link (e.g. because \fIvarName\fR is the +name of array) then TCL_ERROR is returned and \fIinterp->result\fR +contains an error message. +.PP +The \fItype\fR argument specifies the type of the C variable, +and must have one of the following values, optionally OR'ed with +TCL_LINK_READ_ONLY: +.TP +\fBTCL_LINK_INT\fR +The C variable is of type \fBint\fR. +Any value written into the Tcl variable must have a proper integer +form acceptable to \fBTcl_GetInt\fR; attempts to write +non-integer values into \fIvarName\fR will be rejected with +Tcl errors. +.TP +\fBTCL_LINK_DOUBLE\fR +The C variable is of type \fBdouble\fR. +Any value written into the Tcl variable must have a proper real +form acceptable to \fBTcl_GetDouble\fR; attempts to write +non-real values into \fIvarName\fR will be rejected with +Tcl errors. +.TP +\fBTCL_LINK_BOOLEAN\fR +The C variable is of type \fBint\fR. +If its value is zero then it will read from Tcl as ``0''; +otherwise it will read from Tcl as ``1''. +Whenver \fIvarName\fR is +modified, the C variable will be set to a 0 or 1 value. +Any value written into the Tcl variable must have a proper boolean +form acceptable to \fBTcl_GetBoolean\fR; attempts to write +non-boolean values into \fIvarName\fR will be rejected with +Tcl errors. +.TP +\fBTCL_LINK_STRING\fR +The C variable is of type \fBchar *\fR. +If its value is not null then it must be a pointer to a string +allocated with \fBmalloc\fR. +Whenever the Tcl variable is modified the current C string will be +freed and new memory will be allocated to hold a copy of the variable's +new value. +If the C variable contains a null pointer then the Tcl variable +will read as ``NULL''. +.PP +If the TCL_LINK_READ_ONLY flag is present in \fItype\fR then the +variable will be read-only from Tcl, so that its value can only be +changed by modifying the C variable. +Attempts to write the variable from Tcl will be rejected with errors. + +.SH KEYWORDS +boolean, integer, link, read-only, real, string, variable diff --git a/vendor/x11iraf/obm/Tcl/doc/PrintDbl.3 b/vendor/x11iraf/obm/Tcl/doc/PrintDbl.3 new file mode 100644 index 00000000..51d7f884 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/doc/PrintDbl.3 @@ -0,0 +1,58 @@ +'\" +'\" Copyright (c) 1989-1993 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 +'\" documentation for any purpose, provided that the above copyright +'\" notice and the following two paragraphs appear in all copies. +'\" +'\" 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 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. +'\" +'\" $Header: /user6/ouster/tcl/man/RCS/PrintDbl.3,v 1.2 93/06/05 15:32:01 ouster Exp $ SPRITE (Berkeley) +'\" +.so man.macros +.HS Tcl_PrintDouble tclc 7.0 +.BS +.SH NAME +Tcl_PrintDouble \- Convert floating value to string +.SH SYNOPSIS +.nf +\fB#include <tcl.h>\fR +.sp +\fBTcl_PrintDouble\fR(\fIinterp, value, dst\fR) +.SH ARGUMENTS +.AS Tcl_Interp *interp +.AP Tcl_Interp *interp in +Interpreter that controls the conversion. +.AP double value in +Floating-point value to be converted. +.AP char *dst out +Where to store string representing \fIvalue\fR. Must have at +least TCL_DOUBLE_SPACE characters of storage. +.BE + +.SH DESCRIPTION +.PP +\fBTcl_PrintDouble\fR generates a string that represents the value +of \fIvalue\fR and stores it in memory at the location given by +\fIdst\fR. It uses %g format to generate the string, with two +special twists. First, the string is guaranteed to contain either +a ``.'' or an ``e'' so that it doesn't look like an integer (where +%g would generate an integer with no decimal point, \fBTcl_PrintDouble\fR +adds ``.0''). Second, the number of significant digits printed at +\fIdst\fR is controlled by the \fBtcl_precision\fR variable in +\fIinterp\fR; if \fBtcl_precision\fR is undefined then 6 significant +digits are printed. + +.SH KEYWORDS +conversion, double-precision, floating-point, string diff --git a/vendor/x11iraf/obm/Tcl/doc/RecordEval.3 b/vendor/x11iraf/obm/Tcl/doc/RecordEval.3 new file mode 100644 index 00000000..02e11d8c --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/doc/RecordEval.3 @@ -0,0 +1,60 @@ +'\" +'\" Copyright (c) 1989-1993 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 +'\" documentation for any purpose, provided that the above copyright +'\" notice and the following two paragraphs appear in all copies. +'\" +'\" 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 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. +'\" +'\" $Header: /user6/ouster/tcl/man/RCS/RecordEval.3,v 1.9 93/04/16 15:02:27 ouster Exp $ SPRITE (Berkeley) +'\" +.so man.macros +.HS Tcl_RecordAndEval tclc +.BS +.SH NAME +Tcl_RecordAndEval \- save command on history list before evaluating +.SH SYNOPSIS +.nf +\fB#include <tcl.h>\fR +.sp +int +\fBTcl_RecordAndEval\fR(\fIinterp, cmd, eval\fR) +.SH ARGUMENTS +.AS Tcl_Interp *interp; +.AP Tcl_Interp *interp in +Tcl interpreter in which to evaluate command. +.AP char *cmd in +Command (or sequence of commands) to execute. +.AP int eval in +0 means evaluate \fIcmd\fR, TCL_NO_EVAL means record it but don't +evaluate it. +.BE + +.SH DESCRIPTION +.PP +\fBTcl_RecordAndEval\fR is invoked to record a command as an event +on the history list and then execute it. +It returns a completion code such as TCL_OK just like \fBTcl_Eval\fR +and it leaves information in \fIinterp->result\fR. +If you don't want the command recorded on the history list then +you should invoke \fBTcl_Eval\fR instead of \fBTcl_RecordAndEval\fR. +Normally \fBTcl_RecordAndEval\fR is only called with top-level +commands typed by the user, since the purpose of history is to +allow the user to re-issue recently-invoked commands. +If the \fIeval\fR argument is TCL_NO_EVAL then the command is +recorded without being evaluated. + +.SH KEYWORDS +command, event, execute, history, interpreter, record diff --git a/vendor/x11iraf/obm/Tcl/doc/RegExp.3 b/vendor/x11iraf/obm/Tcl/doc/RegExp.3 new file mode 100644 index 00000000..13546ee6 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/doc/RegExp.3 @@ -0,0 +1,57 @@ +'\" +'\" Copyright (c) 1993 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 +'\" documentation for any purpose, provided that the above copyright +'\" notice and the following two paragraphs appear in all copies. +'\" +'\" 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 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. +'\" +'\" $Header: /user6/ouster/tcl/man/RCS/RegExp.3,v 1.1 93/05/05 17:06:04 ouster Exp $ SPRITE (Berkeley) +'\" +.so man.macros +.HS Tcl_RegExpMatch tclc 7.0 +.BS +.SH NAME +Tcl_RegExpMatch \- Test whether a string matches a regular expression +.SH SYNOPSIS +.nf +\fB#include <tcl.h>\fR +.sp +int +\fBTcl_RegExpMatch\fR(\fIinterp\fR, \fIstring\fR, \fIregexp\fR) +.SH ARGUMENTS +.AS Tcl_Interp *interp +.AP Tcl_Interp *interp in +Tcl interpreter to use for error reporting. +.AP char *string in +String to test. +.AP char *regexp in +Regular expression to match against \fIstring\fR. +.BE + +.SH DESCRIPTION +.PP +\fBTcl_RegExpMatch\fR determines whether its \fIstring\fR argument +matches \fIregexp\fR, where \fIregexp\fR is interpreted +as a regular expression using the same rules as for the +\fBregexp\fR Tcl command. +If there is a match then \fBTcl_RegExpMatch\fR returns 1. +If there is no match then \fBTcl_RegExpMatch\fR returns 0. +If an error occurs in the matching process (e.g. \fIregexp\fR +is not a valid regular expression) then \fBTcl_RegExpMatch\fR +returns \-1 and leaves an error message in \fIinterp->result\fR. + +.SH KEYWORDS +match, regular expression, string diff --git a/vendor/x11iraf/obm/Tcl/doc/SetRecLmt.3 b/vendor/x11iraf/obm/Tcl/doc/SetRecLmt.3 new file mode 100644 index 00000000..3010a86d --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/doc/SetRecLmt.3 @@ -0,0 +1,60 @@ +'\" +'\" Copyright (c) 1989-1993 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 +'\" documentation for any purpose, provided that the above copyright +'\" notice and the following two paragraphs appear in all copies. +'\" +'\" 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 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. +'\" +'\" $Header: /user6/ouster/tcl/man/RCS/SetRecLmt.3,v 1.1 93/07/07 16:35:18 ouster Exp $ SPRITE (Berkeley) +'\" +.so man.macros +.HS Tcl_SetRecursionLimit tclc 7.0 +.BS +.SH NAME +Tcl_SetRecursionLimit \- set maximum allowable nesting depth in interpreter +.SH SYNOPSIS +.nf +\fB#include <tcl.h>\fR +.sp +int +\fBTcl_SetRecursionLimit\fR(\fIinterp, depth\fR) +.SH ARGUMENTS +.AS Tcl_Interp *interp +.AP Tcl_Interp *interp in +Interpreter whose recursion limit is to be set. +Must be greater than zero. +.AP int depth in +New limit for nested calls to \fBTcl_Eval\fR for \fIinterp\fR. +.BE + +.SH DESCRIPTION +.PP +At any given time Tcl enforces a limit on the number of recursive +calls that may be active for \fBTcl_Eval\fR and related procedures +such as \fBTcl_GlobalEval\fR. +Any call to \fBTcl_Eval\fR that exceeds this depth is aborted with +an error. +By default the recursion limit is 1000. +.PP +\fBTcl_SetRecursionLimit\fR may be used to change the maximum +allowable nesting depth for an interpreter. +The \fIdepth\fR argument specifies a new limit for \fIinterp\fR, +and \fBTcl_SetRecursionLimit\fR returns the old limit. +To read out the old limit without modifying it, invoke +\fBTcl_SetRecursionDepth\fR with \fIdepth\fR equal to 0. + +.SH KEYWORDS +nesting depth, recursion diff --git a/vendor/x11iraf/obm/Tcl/doc/SetResult.3 b/vendor/x11iraf/obm/Tcl/doc/SetResult.3 new file mode 100644 index 00000000..94835acd --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/doc/SetResult.3 @@ -0,0 +1,162 @@ +'\" +'\" Copyright (c) 1989-1993 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 +'\" documentation for any purpose, provided that the above copyright +'\" notice and the following two paragraphs appear in all copies. +'\" +'\" 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 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. +'\" +'\" $Header: /user6/ouster/tcl/man/RCS/SetResult.3,v 1.12 93/04/03 15:05:59 ouster Exp $ SPRITE (Berkeley) +'\" +.so man.macros +.HS Tcl_SetResult tclc 7.0 +.BS +.SH NAME +Tcl_SetResult, Tcl_AppendResult, Tcl_AppendElement, Tcl_ResetResult \- manipulate Tcl result string +.SH SYNOPSIS +.nf +\fB#include <tcl.h>\fR +.sp +\fBTcl_SetResult\fR(\fIinterp, string, freeProc\fR) +.sp +\fBTcl_AppendResult(\fIinterp, string, string, ... , \fB(char *) NULL\fR) +.sp +.VS +\fBTcl_AppendElement\fR(\fIinterp, string\fR) +.VE +.sp +\fBTcl_ResetResult\fR(\fIinterp\fR) +.sp +\fBTcl_FreeResult\fR(\fIinterp\fR) +.SH ARGUMENTS +.AS Tcl_FreeProc freeProc +.AP Tcl_Interp *interp out +Interpreter whose result is to be modified. +.AP char *string in +String value to become result for \fIinterp\fR or to be +appended to existing result. +.AP Tcl_FreeProc freeProc in +Address of procedure to call to release storage at +\fIstring\fR, or \fBTCL_STATIC\fR, \fBTCL_DYNAMIC\fR, or +\fBTCL_VOLATILE\fR. +.BE + +.SH DESCRIPTION +.PP +The procedures described here are utilities for setting the +result/error string in a Tcl interpreter. +.PP +\fBTcl_SetResult\fR +arranges for \fIstring\fR to be the return string for the current Tcl +command in \fIinterp\fR, replacing any existing result. +If \fIfreeProc\fR is \fBTCL_STATIC\fR it means that \fIstring\fR +refers to an area of static storage that is guaranteed not to be +modified until at least the next call to \fBTcl_Eval\fR. +If \fIfreeProc\fR +is \fBTCL_DYNAMIC\fR it means that \fIstring\fR was allocated with a call +to \fBmalloc()\fR and is now the property of the Tcl system. +\fBTcl_SetResult\fR will arrange for the string's storage to be +released by calling \fBfree()\fR when it is no longer needed. +If \fIfreeProc\fR is \fBTCL_VOLATILE\fR it means that \fIstring\fR +points to an area of memory that is likely to be overwritten when +\fBTcl_SetResult\fR returns (e.g. it points to something in a stack frame). +In this case \fBTcl_SetResult\fR will make a copy of the string in +dynamically allocated storage and arrange for the copy to be the +return string for the current Tcl command. +.PP +If \fIfreeProc\fR isn't one of the values \fBTCL_STATIC\fR, +\fBTCL_DYNAMIC\fR, and \fBTCL_VOLATILE\fR, then it is the address +of a procedure that Tcl should call to free the string. +This allows applications to use non-standard storage allocators. +When Tcl no longer needs the storage for the string, it will +call \fIfreeProc\fR. \fIFreeProc\fR should have arguments and +result that match the type \fBTcl_FreeProc\fR: +.nf +.RS + +typedef void Tcl_FreeProc(char *\fIblockPtr\fR); + +.RE +.fi +When \fIfreeProc\fR is called, its \fIblockPtr\fR will be set to +the value of \fIstring\fR passed to \fBTcl_SetResult\fR. +.PP +If \fIstring\fR is \fBNULL\fR, then \fIfreeProc\fR is ignored +and \fBTcl_SetResult\fR +re-initializes \fIinterp\fR's result to point to the pre-allocated result +area, with an empty string in the result area. +.PP +If \fBTcl_SetResult\fR is called at a time when \fIinterp\fR holds a +result, \fBTcl_SetResult\fR does whatever is necessary to dispose +of the old result (see the \fBTcl_Interp\fR manual entry for details +on this). +.PP +\fBTcl_AppendResult\fR makes it easy to build up Tcl results in pieces. +It takes each of its \fIstring\fR arguments and appends them in order +to the current result associated with \fIinterp\fR. +If the result is in its initialized empty state (e.g. a command procedure +was just invoked or \fBTcl_ResetResult\fR was just called), +then \fBTcl_AppendResult\fR sets the result to the concatenation of +its \fIstring\fR arguments. +\fBTcl_AppendResult\fR may be called repeatedly as additional pieces +of the result are produced. +\fBTcl_AppendResult\fR takes care of all the +storage management issues associated with managing \fIinterp\fR's +result, such as allocating a larger result area if necessary. +Any number of \fIstring\fR arguments may be passed in a single +call; the last argument in the list must be a NULL pointer. +.PP +\fBTcl_AppendElement\fR is similar to \fBTcl_AppendResult\fR in +that it allows results to be built up in pieces. +However, \fBTcl_AppendElement\fR takes only a single \fIstring\fR +argument and it appends that argument to the current result +as a proper Tcl list element. +\fBTcl_AppendElement\fR adds backslashes or braces if necessary +to ensure that \fIinterp\fR's result can be parsed as a list and that +\fIstring\fR will be extracted as a single element. +Under normal conditions, \fBTcl_AppendElement\fR will add a space +character to \fIinterp\fR's result just before adding the new +list element, so that the list elements in the result are properly +separated. +.VS +However if the new list element is the first in a list or sub-list +(i.e. \fIinterp\fR's current result is empty, or consists of the +single character ``{'', or ends in the characters `` {'') then no +space is added. +.VE +.PP +\fBTcl_ResetResult\fR clears the result for \fIinterp\fR, +freeing the memory associated with it if the current result was +dynamically allocated. +It leaves the result in its normal initialized state with +\fIinterp->result\fR pointing to a static buffer containing +\fBTCL_RESULT_SIZE\fR characters, of which the first character +is zero. +\fBTcl_ResetResult\fR also clears the error state managed by +\fBTcl_AddErrorInfo\fR and \fBTcl_SetErrorCode\fR. +.PP +\fBTcl_FreeResult\fR is a macro that performs part of the work +of \fBTcl_ResetResult\fR. +It frees up the memory associated with \fIinterp\fR's result +and sets \fIinterp->freeProc\fR to zero, but it doesn't +change \fIinterp->result\fR or clear error state. +\fBTcl_FreeResult\fR is most commonly used when a procedure +is about to replace one result value with another. + +.SH "SEE ALSO" +Tcl_AddErrorInfo, Tcl_SetErrorCode, Tcl_Interp + +.SH KEYWORDS +append, command, element, list, result, return value, interpreter diff --git a/vendor/x11iraf/obm/Tcl/doc/SetVar.3 b/vendor/x11iraf/obm/Tcl/doc/SetVar.3 new file mode 100644 index 00000000..087ebf8c --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/doc/SetVar.3 @@ -0,0 +1,166 @@ +'\" +'\" Copyright (c) 1989-1993 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 +'\" documentation for any purpose, provided that the above copyright +'\" notice and the following two paragraphs appear in all copies. +'\" +'\" 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 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. +'\" +'\" $Header: /user6/ouster/tcl/man/RCS/SetVar.3,v 1.15 93/06/05 15:40:17 ouster Exp $ SPRITE (Berkeley) +'\" +.so man.macros +.HS Tcl_SetVar tclc 7.0 +.BS +.SH NAME +Tcl_SetVar, Tcl_SetVar2, Tcl_GetVar, Tcl_GetVar2, Tcl_UnsetVar, Tcl_UnsetVar2 \- manipulate Tcl variables +.SH SYNOPSIS +.nf +\fB#include <tcl.h>\fR +.sp +char * +\fBTcl_SetVar\fR(\fIinterp, varName, newValue, flags\fR) +.sp +char * +\fBTcl_SetVar2\fR(\fIinterp, name1, name2, newValue, flags\fR) +.sp +char * +\fBTcl_GetVar\fR(\fIinterp, varName, flags\fR) +.sp +char * +\fBTcl_GetVar2\fR(\fIinterp, name1, name2, flags\fR) +.sp +int +\fBTcl_UnsetVar\fR(\fIinterp, varName, flags\fR) +.sp +int +\fBTcl_UnsetVar2\fR(\fIinterp, name1, name2, flags\fR) +.SH ARGUMENTS +.AS Tcl_Interp *newValue +.AP Tcl_Interp *interp in +Interpreter containing variable. +.AP char *varName in +Name of variable. May refer to a scalar variable or an element of +an array variable. +.AP char *newValue in +New value for variable. +.AP int flags in +OR-ed combination of bits providing additional information for +operation. See below for valid values. +.AP char *name1 in +Name of scalar variable, or name of array variable if \fIname2\fR +is non-NULL. +.AP char *name2 in +If non-NULL, gives name of element within array and \fIname1\fR +must refer to an array variable. +.BE + +.SH DESCRIPTION +.PP +These procedures may be used to create, modify, read, and delete +Tcl variables from C code. +\fBTcl_SetVar\fR and \fBTcl_SetVar2\fR will create a new variable +or modify an existing one. +Both of these procedures set the given variable to the value +given by \fInewValue\fR, and they return a pointer to a +copy of the variable's new value, which is stored in Tcl's +variable structure. +Tcl keeps a private copy of the variable's value, so the caller +may change \fInewValue\fR after these procedures return without +affecting the value of the variable. +If an error occurs in setting the variable (e.g. an array +variable is referenced without giving an index into the array), +then NULL is returned. +.PP +The name of the variable may be specified in either of two ways. +If \fBTcl_SetVar\fR is called, the variable name is given as +a single string, \fIvarName\fR. +If \fIvarName\fR contains an open parenthesis and ends with a +close parenthesis, then the value between the parentheses is +treated as an index (which can have any string value) and +the characters before the first open +parenthesis are treated as the name of an array variable. +If \fIvarName\fR doesn't have parentheses as described above, then +the entire string is treated as the name of a scalar variable. +If \fBTcl_SetVar2\fR is called, then the array name and index +have been separated by the caller into two separate strings, +\fIname1\fR and \fIname2\fR respectively; if \fIname2\fR is +zero it means that a scalar variable is being referenced. +.PP +The \fIflags\fR argument may be used to specify any of several +options to the procedures. +It consists of an OR-ed combination of any of the following +bits: +.IP TCL_GLOBAL_ONLY +Under normal circumstances the procedures look up variables +at the current level of procedure call for \fIinterp\fR, or +at global level if there is no call active. +However, if this bit is set in \fIflags\fR then the variable +is looked up at global level even if there is a procedure +call active. +.IP TCL_LEAVE_ERR_MSG +If an error is returned and this bit is set in \fIflags\fR, then +an error message will be left in \fI\%interp->result\fR. If this +flag bit isn't set then no error message is left (\fI\%interp->result\fR +will not be modified). +.IP TCL_APPEND_VALUE +If this bit is set then \fInewValue\fR is appended to the current +value, instead of replacing it. +If the variable is currently undefined, then this bit is ignored. +.IP TCL_LIST_ELEMENT +If this bit is set, then \fInewValue\fR is converted to a valid +Tcl list element before setting (or appending to) the variable. +A separator space is appended before the new list element unless +.VS +the list element is going to be the first element in a list or +sublist (i.e. the variable's current value is empty, or contains +the single character ``{'', or ends in `` }''). +.VE +.PP +\fBTcl_GetVar\fR and \fBTcl_GetVar2\fR return the current value +of a variable. +The arguments to these procedures are treated in the same way +as the arguments to \fBTcl_SetVar\fR and \fBTcl_SetVar2\fR. +Under normal circumstances, the return value is a pointer +to the variable's value (which is stored in Tcl's variable +structure and will not change before the next call to \fBTcl_SetVar\fR +or \fBTcl_SetVar2\fR). +The only bits of \fIflags\fR that are used are TCL_GLOBAL_ONLY +and TCL_LEAVE_ERR_MSG, both of +which have +the same meaning as for \fBTcl_SetVar\fR. +If an error occurs in reading the variable (e.g. the variable +doesn't exist or an array element is specified for a scalar +variable), then NULL is returned. +.PP +\fBTcl_UnsetVar\fR and \fBTcl_UnsetVar2\fR may be used to remove +a variable, so that future calls to \fBTcl_GetVar\fR or \fBTcl_GetVar2\fR +for the variable will return an error. +The arguments to these procedures are treated in the same way +as the arguments to \fBTcl_GetVar\fR and \fBTcl_GetVar2\fR. +.VS +If the variable is successfully removed then TCL_OK is returned. +If the variable cannot be removed because it doesn't exist then +TCL_ERROR is returned. +.VE +If an array element is specified, the given element is removed +but the array remains. +If an array name is specified without an index, then the entire +array is removed. + +.SH "SEE ALSO" +Tcl_TraceVar + +.SH KEYWORDS +array, interpreter, scalar, set, unset, variable diff --git a/vendor/x11iraf/obm/Tcl/doc/SplitList.3 b/vendor/x11iraf/obm/Tcl/doc/SplitList.3 new file mode 100644 index 00000000..c5964896 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/doc/SplitList.3 @@ -0,0 +1,164 @@ +'\" +'\" Copyright (c) 1989-1993 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 +'\" documentation for any purpose, provided that the above copyright +'\" notice and the following two paragraphs appear in all copies. +'\" +'\" 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 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. +'\" +'\" $Header: /user6/ouster/tcl/man/RCS/SplitList.3,v 1.11 93/04/01 09:25:34 ouster Exp $ SPRITE (Berkeley) +'\" +.so man.macros +.HS Tcl_SplitList tclc +.BS +.SH NAME +Tcl_SplitList, Tcl_Merge, Tcl_ScanElement, Tcl_ConvertElement \- manipulate Tcl lists +.SH SYNOPSIS +.nf +\fB#include <tcl.h>\fR +.sp +int +\fBTcl_SplitList\fR(\fIinterp, list, argcPtr, argvPtr\fR) +.sp +char * +\fBTcl_Merge\fR(\fIargc, argv\fR) +.sp +int +\fBTcl_ScanElement\fR(\fIsrc, flagsPtr\fR) +.sp +int +\fBTcl_ConvertElement\fR(\fIsrc, dst, flags\fR) +.SH ARGUMENTS +.AS Tcl_Interp ***argvPtr +.AP Tcl_Interp *interp out +Interpreter to use for error reporting. +.AP char *list in +Pointer to a string with proper list structure. +.AP int *argcPtr out +Filled in with number of elements in \fIlist\fR. +.AP char ***argvPtr out +\fI*argvPtr\fR will be filled in with the address of an array of +pointers to the strings that are the extracted elements of \fIlist\fR. +There will be \fI*argcPtr\fR valid entries in the array, followed by +a NULL entry. +.AP int argc in +Number of elements in \fIargv\fR. +.AP char **argv in +Array of strings to merge together into a single list. +Each string will become a separate element of the list. +.AP char *src in +String that is to become an element of a list. +.AP int *flagsPtr in +Pointer to word to fill in with information about \fIsrc\fR. +The value of *\fIflagsPtr\fR must be passed to \fBTcl_ConvertElement\fR. +.AP char *dst in +Place to copy converted list element. Must contain enough characters +to hold converted string. +.AP int flags in +Information about \fIsrc\fR. Must be value returned by previous +call to \fBTcl_ScanElement\fR, possibly OR-ed +with \fBTCL_DONT_USE_BRACES\fR. +.BE + +.SH DESCRIPTION +.PP +These procedures may be used to disassemble and reassemble Tcl lists. +\fBTcl_SplitList\fR breaks a list up into its constituent elements, +returning an array of pointers to the elements using +\fIargcPtr\fR and \fIargvPtr\fR. +While extracting the arguments, \fBTcl_SplitList\fR obeys the usual +rules for backslash substitutions and braces. The area of +memory pointed to by \fI*argvPtr\fR is dynamically allocated; in +addition to the array of pointers, it +also holds copies of all the list elements. It is the caller's +responsibility to free up all of this storage by calling +.DS +\fBfree\fR((char *) \fI*argvPtr\fR) +.DE +when the list elements are no longer needed. +.PP +\fBTcl_SplitList\fR normally returns \fBTCL_OK\fR, which means the list was +successfully parsed. +If there was a syntax error in \fIlist\fR, then \fBTCL_ERROR\fR is returned +and \fIinterp->result\fR will point to an error message describing the +problem. +If \fBTCL_ERROR\fR is returned then no memory is allocated and \fI*argvPtr\fR +is not modified. +.PP +\fBTcl_Merge\fR is the inverse of \fBTcl_SplitList\fR: it +takes a collection of strings given by \fIargc\fR +and \fIargv\fR and generates a result string +that has proper list structure. +This means that commands like \fBindex\fR may be used to +extract the original elements again. +In addition, if the result of \fBTcl_Merge\fR is passed to \fBTcl_Eval\fR, +it will be parsed into \fIargc\fR words whose values will +be the same as the \fIargv\fR strings passed to \fBTcl_Merge\fR. +\fBTcl_Merge\fR will modify the list elements with braces and/or +backslashes in order to produce proper Tcl list structure. +The result string is dynamically allocated +using \fBmalloc()\fR; the caller must eventually release the space +using \fBfree()\fR. +.PP +If the result of \fBTcl_Merge\fR is passed to \fBTcl_SplitList\fR, +the elements returned by \fBTcl_SplitList\fR will be identical to +those passed into \fBTcl_Merge\fR. +However, the converse is not true: if \fBTcl_SplitList\fR +is passed a given string, and the resulting \fIargc\fR and +\fIargv\fR are passed to \fBTcl_Merge\fR, the resulting string +may not be the same as the original string passed to \fBTcl_SplitList\fR. +This is because \fBTcl_Merge\fR may use backslashes and braces +differently than the original string. +.PP +\fBTcl_ScanElement\fR and \fBTcl_ConvertElement\fR are the +procedures that do all of the real work of \fBTcl_Merge\fR. +\fBTcl_ScanElement\fR scans its \fIsrc\fR argument +and determines how to use backslashes and braces +when converting it to a list element. +It returns an overestimate of the number of characters +required to represent \fIsrc\fR as a list element, and +it stores information in \fI*flagsPtr\fR that is needed +by \fBTcl_ConvertElement\fR. +.PP +\fBTcl_ConvertElement\fR is a companion procedure to \fBTcl_ScanElement\fR. +It does the actual work of converting a string to a list element. +Its \fIflags\fR argument must be the same as the value returned +by \fBTcl_ScanElement\fR. +\fBTcl_ConvertElement\fR writes a proper list element to memory +starting at *\fIdst\fR and returns a count of the total number +of characters written, which will be no more than the result +returned by \fBTcl_ScanElement\fR. +\fBTcl_ConvertElement\fR writes out only the actual list element +without any leading or trailing spaces: it is up to the caller to +include spaces between adjacent list elements. +.PP +\fBTcl_ConvertElement\fR uses one of two different approaches to +handle the special characters in \fIsrc\fR. Wherever possible, it +handles special characters by surrounding the string with braces. +This produces clean-looking output, but can't be used in some situations, +such as when \fIsrc\fR contains unmatched braces. +In these situations, \fBTcl_ConvertElement\fR handles special +characters by generating backslash sequences for them. +The caller may insist on the second approach by OR-ing the +flag value returned by \fBTcl_ScanElement\fR with +\fBTCL_DONT_USE_BRACES\fR. +Although this will produce an uglier result, it is useful in some +special situations, such as when \fBTcl_ConvertElement\fR is being +used to generate a portion of an argument for a Tcl command. +In this case, surrounding \fIsrc\fR with curly braces would cause +the command not to be parsed correctly. + +.SH KEYWORDS +backslash, convert, element, list, merge, split, strings diff --git a/vendor/x11iraf/obm/Tcl/doc/StrMatch.3 b/vendor/x11iraf/obm/Tcl/doc/StrMatch.3 new file mode 100644 index 00000000..d99c648f --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/doc/StrMatch.3 @@ -0,0 +1,52 @@ +'\" +'\" Copyright (c) 1989-1993 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 +'\" documentation for any purpose, provided that the above copyright +'\" notice and the following two paragraphs appear in all copies. +'\" +'\" 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 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. +'\" +'\" $Header: /user6/ouster/tcl/man/RCS/StrMatch.3,v 1.7 93/04/01 09:25:35 ouster Exp $ SPRITE (Berkeley) +'\" +.so man.macros +.HS Tcl_StringMatch tclc +.BS +.SH NAME +Tcl_StringMatch \- test whether a string matches a pattern +.SH SYNOPSIS +.nf +\fB#include <tcl.h>\fR +.sp +int +\fBTcl_StringMatch\fR(\fIstring\fR, \fIpattern\fR) +.SH ARGUMENTS +.AP char *string in +String to test. +.AP char *pattern in +Pattern to match against string. May contain special +characters from the set *?\e[]. +.BE + +.SH DESCRIPTION +.PP +This utility procedure determines whether a string matches +a given pattern. If it does, then \fBTcl_StringMatch\fR returns +1. Otherwise \fBTcl_StringMatch\fR returns 0. The algorithm +used for matching is the same algorithm used in the ``string match'' +Tcl command and is similar to the algorithm used by the C-shell +for file name matching; see the Tcl manual entry for details. + +.SH KEYWORDS +match, pattern, string diff --git a/vendor/x11iraf/obm/Tcl/doc/Tcl.n b/vendor/x11iraf/obm/Tcl/doc/Tcl.n new file mode 100644 index 00000000..e6d85731 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/doc/Tcl.n @@ -0,0 +1,205 @@ +'\" +'\" Copyright (c) 1993 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 +'\" documentation for any purpose, provided that the above copyright +'\" notice and the following two paragraphs appear in all copies. +'\" +'\" 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 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. +'\" +'\" $Header: /user6/ouster/tcl/man/RCS/Tcl.n,v 1.118 93/07/28 14:13:25 ouster Exp $ SPRITE (Berkeley) +' +.so man.macros +.de UL +\\$1\l'|0\(ul'\\$2 +.. +.HS Tcl tcl +.BS +.SH NAME +Tcl \- Summary of Tcl language syntax. +.BE + +.SH DESCRIPTION +.LP +The following rules define the syntax and semantics of the Tcl language: +.IP [1] +A Tcl script is a string containing one or more commands. +Semi-colons and newlines are command separators unless quoted as +described below. +Close brackets are command terminators during command substitution +(see below) unless quoted. +.IP [2] +A command is evaluated in two steps. +First, the Tcl interpreter breaks the command into \fIwords\fR +and performs substitutions as described below. +These substitutions are performed in the same way for all +commands. +The first word is used to locate a command procedure to +carry out the command, then all of the words of the command are +passed to the command procedure. +The command procedure is free to interpret each of its words +in any way it likes, such as an integer, variable name, list, +or Tcl script. +Different commands interpret their words differently. +.IP [3] +Words of a command are separated by white space (except for +newlines, which are command separators). +.IP [4] +If the first character of a word is double-quote (``"'') then +the word is terminated by the next double-quote character. +If semi-colons, close brackets, or white space characters +(including newlines) appear between the quotes then they are treated +as ordinary characters and included in the word. +Command substitution, variable substitution, and backslash substitution +are performed on the characters between the quotes as described below. +The double-quotes are not retained as part of the word. +.IP [5] +If the first character of a word is an open brace (``{'') then +the word is terminated by the matching close brace (``}''). +Braces nest within the word: for each additional open +brace there must be an additional close brace (however, +if an open brace or close brace within the word is +quoted with a backslash then it is not counted in locating the +matching close brace). +No substitutions are performed on the characters between the +braces except for backslash-newline substitutions described +below, nor do semi-colons, newlines, close brackets, +or white space receive any special interpretation. +The word will consist of exactly the characters between the +outer braces, not including the braces themselves. +.IP [6] +If a word contains an open bracket (``['') then Tcl performs +\fIcommand substitution\fR. +To do this it invokes the Tcl interpreter recursively to process +the characters following the open bracket as a Tcl script. +The script may contain any number of commands and must be terminated +by a close bracket (``]''). +The result of the script (i.e. the result of its last command) is +substituted into the word in place of the brackets and all of the +characters between them. +There may be any number of command substitutions in a single word. +Command substitution is not performed on words enclosed in braces. +.IP [7] +If a word contains a dollar-sign (``$'') then Tcl performs \fIvariable +substitution\fR: the dollar-sign and the following characters are +replaced in the word by the value of a variable. +Variable substition may take any of the following forms: +.RS +.TP 15 +\fB$\fIname\fR +\fIName\fR is the name of a scalar variable; the name is terminated +by any character that isn't a letter, digit, or underscore. +.TP 15 +\fB$\fIname\fB(\fIindex\fB)\fR +\fIName\fR gives the name of an array variable and \fIindex\fR gives +the name of an element within that array. +\fIName\fR must contain only letters, digits, and underscores. +Command substitutions, variable substitutions, and backslash +substitutions are performed on the characters of \fIindex\fR. +.TP 15 +\fB${\fIname\fB}\fR +\fIName\fR is the name of a scalar variable. It may contain any +characters whatsoever except for close braces. +.RE +.LP +There may be any number of variable substitutions in a single word. +Variable substitution is not performed on words enclosed in braces. +.IP [8] +If a backslash (``\e'') appears within a word then +\fIbackslash substitution\fR occurs. +.VS +In all cases but those described below the backslash is dropped and +the following character is treated as an ordinary +character and included in the word. +.VE +This allows characters such as double quotes, close brackets, +and dollar signs to be included in words without triggering +special processing. +The following table lists the backslash sequences that are +handled specially, along with the value that replaces each sequence. +.RS +.VS +.TP 6 +\e\fBa\fR +Audible alert (bell) (0x7). +.VE +.TP 6 +\e\fBb\fR +Backspace (0x8). +.TP 6 +\e\fBf\fR +Form feed (0xc). +.TP 6 +\e\fBn\fR +Newline (0xa). +.TP 6 +\e\fBr\fR +Carriage-return (0xd). +.TP 6 +\e\fBt\fR +Tab (0x9). +.TP 6 +\e\fBv\fR +Vertical tab (0xb). +.TP 6 +\e\fB<newline>\fIwhiteSpace\fR\fR +.VS +A single space character replaces the backslash, newline, and all +white space after the newline. +This backslash sequence is unique in that it is replaced in a separate +pre-pass before the command is actually parsed. +This means that it will be replaced even when it occurs between +braces, and the resulting space will be treated as a word separator +if it isn't in braces or quotes. +.VE +.TP 6 +\e\e +Backslash (``\e''). +.TP 6 +\e\fIooo\fR +The digits \fIooo\fR (one, two, or three of them) give the octal value of +the character. +.TP 6 +\e\fBx\fIhh\fR +.VS +The hexadecimal digits \fIhh\fR give the hexadecimal value of +the character. Any number of digits may be present. +.VE +.RE +.LP +Backslash substitution is not performed on words enclosed in braces, +except for backslash-newline as described above. +.IP [9] +If a hash character (``#'') appears at a point where Tcl is +expecting the first character of the first word of a command, +then the hash character and the characters that follow it, up +through the next newline, are treated as a comment and ignored. +The comment character only has significance when it appears +at the beginning of a command. +.IP [10] +Each character is processed exactly once by the Tcl interpreter +as part of creating the words of a command. +For example, if variable substition occurs then no further +substitions are performed on the value of the variable; the +value is inserted into the word verbatim. +If command substitution occurs then the nested command is +processed entirely by the recursive call to the Tcl interpreter; +no substitutions are perfomed before making the recursive +call and no additional substitutions are performed on the result +of the nested script. +.IP [11] +Substitutions do not affect the word boundaries of a command. +For example, during variable substitution the entire value of +the variable becomes part of a single word, even if the variable's +value contains spaces. diff --git a/vendor/x11iraf/obm/Tcl/doc/TildeSubst.3 b/vendor/x11iraf/obm/Tcl/doc/TildeSubst.3 new file mode 100644 index 00000000..1d1bdeda --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/doc/TildeSubst.3 @@ -0,0 +1,85 @@ +'\" +'\" Copyright (c) 1989-1993 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 +'\" documentation for any purpose, provided that the above copyright +'\" notice and the following two paragraphs appear in all copies. +'\" +'\" 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 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. +'\" +'\" $Header: /user6/ouster/tcl/man/RCS/TildeSubst.3,v 1.10 93/04/08 14:00:43 ouster Exp $ SPRITE (Berkeley) +'\" +.so man.macros +.HS Tcl_TildeSubst tclc 7.0 +.BS +.SH NAME +Tcl_TildeSubst \- replace tilde with home directory in a file name +.SH SYNOPSIS +.nf +\fB#include <tcl.h>\fR +.sp +char * +.VS +\fBTcl_TildeSubst\fR(\fIinterp\fR, \fIname\fR, \fIbufferPtr) +.VE +.SH ARGUMENTS +.AS Tcl_DString *bufferPtr +.AP Tcl_Interp *interp in +Interpreter in which to report an error, if any. +.AP char *name in +File name, which may start with a ``~''. +.AP Tcl_DString *bufferPtr +.VS +If needed, this dynamic string is used to store the new file name. +At the time of the call it should be uninitialized or empty. The +caller must eventually call \fBTcl_DStringFree\fR to free up +anything stored here. +.VE +.BE + +.SH DESCRIPTION +.PP +This utility procedure does tilde substition. If \fIname\fR doesn't +start with a ``~'' character, then the procedure returns \fIname\fR. +If \fIname\fR does start with a tilde, then \fBTcl_TildeSubst\fR +returns a new string identical to \fIname\fR except that the first +element of \fIname\fR is replaced with the location of the home +directory for the given user. The substitution is carried out in +the same way that it would be done by \fIcsh\fR. If the tilde is +followed immediately by a slash, then the \fB$HOME\fR environment +variable is substituted. Otherwise the characters between the +tilde and the next slash are taken as a user name, which is +looked up in the password file; the user's home directory is +retrieved from the password file and substituted. +.PP +If +.VS +\fBTcl_TildeSubst\fR has to do tilde substitution then it uses +the dynamic string at \fI*bufferPtr\fR to hold the new string it +generates. After \fBTcl_TildeSubst\fR returns, the caller must +eventually invoke \fBTcl_DStringFree\fR to free up any information +placed in \fI*bufferPtr\fR. The caller need not know whether or +not \fBTcl_TildeSubst\fR actually used the string; \fBTcl_TildeSubst\fR +initializes \fI*bufferPtr\fR even if it doesn't use it, so the call to +\fBTcl_DStringFree\fR will be safe in either case. +.VE +.PP +If an error occurs (e.g. because there was no user by the given +name) then NULL is returned and an error message will be left +at \fIinterp->result\fR. It is assumed that \fIinterp->result\fR +has been initialized in the standard way when \fBTcl_TildeSubst\fR +is invoked. + +.SH KEYWORDS +file name, home directory, tilde, user diff --git a/vendor/x11iraf/obm/Tcl/doc/TraceVar.3 b/vendor/x11iraf/obm/Tcl/doc/TraceVar.3 new file mode 100644 index 00000000..3ddfecff --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/doc/TraceVar.3 @@ -0,0 +1,361 @@ +'\" +'\" Copyright (c) 1989-1993 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 +'\" documentation for any purpose, provided that the above copyright +'\" notice and the following two paragraphs appear in all copies. +'\" +'\" 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 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. +'\" +'\" $Header: /user6/ouster/tcl/man/RCS/TraceVar.3,v 1.14 93/05/03 15:53:18 ouster Exp $ SPRITE (Berkeley) +'\" +.so man.macros +.HS Tcl_TraceVar tclc +.BS +.SH NAME +Tcl_TraceVar, Tcl_TraceVar2, Tcl_UntraceVar, Tcl_UntraceVar2, Tcl_VarTraceInfo, Tcl_VarTraceInfo2 \- monitor accesses to a variable +.SH SYNOPSIS +.nf +\fB#include <tcl.h>\fR +.sp +int +\fBTcl_TraceVar(\fIinterp, varName, flags, proc, clientData\fB)\fR +.sp +int +\fBTcl_TraceVar2(\fIinterp, name1, name2, flags, proc, clientData\fB)\fR +.sp +\fBTcl_UntraceVar(\fIinterp, varName, flags, proc, clientData\fB)\fR +.sp +\fBTcl_UntraceVar2(\fIinterp, name1, name2, flags, proc, clientData\fB)\fR +.sp +ClientData +\fBTcl_VarTraceInfo(\fIinterp, varName, flags, proc, prevClientData\fB)\fR +.sp +ClientData +\fBTcl_VarTraceInfo2(\fIinterp, name1, name2, flags, proc, prevClientData\fB)\fR +.SH ARGUMENTS +.AS Tcl_VarTraceProc prevClientData +.AP Tcl_Interp *interp in +Interpreter containing variable. +.AP char *varName in +Name of variable. May refer to a scalar variable, to +an array variable with no index, or to an array variable +with a parenthesized index. +.AP int flags in +OR-ed combination of the values TCL_TRACE_READS, TCL_TRACE_WRITES, and +TCL_TRACE_UNSETS, and TCL_GLOBAL_ONLY. Not all flags are used by all +procedures. See below for more information. +.AP Tcl_VarTraceProc *proc in +Procedure to invoke whenever one of the traced operations occurs. +.AP ClientData clientData in +Arbitrary one-word value to pass to \fIproc\fR. +.AP char *name1 in +Name of scalar or array variable (without array index). +.AP char *name2 in +For a trace on an element of an array, gives the index of the +element. For traces on scalar variables or on whole arrays, +is NULL. +.AP ClientData prevClientData in +If non-NULL, gives last value returned by \fBTcl_VarTraceInfo\fR or +\fBTcl_VarTraceInfo2\fR, so this call will return information about +next trace. If NULL, this call will return information about first +trace. +.BE + +.SH DESCRIPTION +.PP +\fBTcl_TraceVar\fR allows a C procedure to monitor and control +access to a Tcl variable, so that the C procedure is invoked +whenever the variable is read or written or unset. +If the trace is created successfully then \fBTcl_TraceVar\fR returns +TCL_OK. If an error occurred (e.g. \fIvarName\fR specifies an element +of an array, but the actual variable isn't an array) then TCL_ERROR +is returned and an error message is left in \fIinterp->result\fR. +.PP +The \fIflags\fR argument to \fBTcl_TraceVar\fR indicates when the +trace procedure is to be invoked and provides information +for setting up the trace. It consists of an OR-ed combination +of any of the following values: +.TP +\fBTCL_GLOBAL_ONLY\fR +Normally, the variable will be looked up at the current level of +procedure call; if this bit is set then the variable will be looked +up at global level, ignoring any active procedures. +.TP +\fBTCL_TRACE_READS\fR +Invoke \fIproc\fR whenever an attempt is made to read the variable. +.TP +\fBTCL_TRACE_WRITES\fR +Invoke \fIproc\fR whenever an attempt is made to modify the variable. +.TP +\fBTCL_TRACE_UNSETS\fR +Invoke \fIproc\fR whenever the variable is unset. +A variable may be unset either explicitly by an \fBunset\fR command, +or implicitly when a procedure returns (its local variables are +automatically unset) or when the interpreter is deleted (all +variables are automatically unset). +.PP +Whenever one of the specified operations occurs on the variable, +\fIproc\fR will be invoked. +It should have arguments and result that match the type +\fBTcl_VarTraceProc\fR: +.nf +.RS +typedef char *Tcl_VarTraceProc( +.RS +ClientData \fIclientData\fR, +Tcl_Interp *\fIinterp\fR, +char *\fIname1\fR, +char *\fIname2\fR, +int \fIflags\fR); +.RE +.RE +.fi +The \fIclientData\fP and \fIinterp\fP parameters will +have the same values as those passed to \fBTcl_TraceVar\fR when the +trace was created. +\fIClientData\fR typically points to an application-specific +data structure that describes what to do when \fIproc\fR +is invoked. +\fIName1\fR and \fIname2\fR give the name of the traced variable +in the normal two-part form (see the description of \fBTcl_TraceVar2\fR +below for details). +\fIFlags\fR is an OR-ed combination of bits providing several +pieces of information. +One of the bits TCL_TRACE_READS, TCL_TRACE_WRITES, or TCL_TRACE_UNSETS +will be set in \fIflags\fR to indicate which operation is being performed +on the variable. +The bit TCL_GLOBAL_ONLY will be set whenever the variable being +accessed is a global one not accessible from the current level of +procedure call: the trace procedure will need to pass this flag +back to variable-related procedures like \fBTcl_GetVar\fR if it +attempts to access the variable. +The bit TCL_TRACE_DESTROYED will be set in \fIflags\fR if the trace is +about to be destroyed; this information may be useful to \fIproc\fR +so that it can clean up its own internal data structures (see +the section TCL_TRACE_DESTROYED below for more details). +Lastly, the bit TCL_INTERP_DESTROYED will be set if the entire +interpreter is being destroyed. +When this bit is set, \fIproc\fR must be especially careful in +the things it does (see the section TCL_INTERP_DESTROYED below). +The trace procedure's return value should normally be NULL; see +ERROR RETURNS below for information on other possibilities. +.PP +\fBTcl_UntraceVar\fR may be used to remove a trace. +If the variable specified by \fIinterp\fR, \fIvarName\fR, and \fIflags\fR +has a trace set with \fIflags\fR, \fIproc\fR, and +\fIclientData\fR, then the corresponding trace is removed. +If no such trace exists, then the call to \fBTcl_UntraceVar\fR +has no effect. +The same bits are valid for \fIflags\fR as for calls to \fBTcl_TraceVars\fR. +.PP +\fBTcl_VarTraceInfo\fR may be used to retrieve information about +traces set on a given variable. +The return value from \fBTcl_VarTraceInfo\fR is the \fIclientData\fR +associated with a particular trace. +The trace must be on the variable specified by the \fIinterp\fR, +\fIvarName\fR, and \fIflags\fR arguments (only the TCL_GLOBAL_ONLY +bit from \fIflags\fR is used; other bits are ignored) and its trace procedure +must the same as the \fIproc\fR argument. +If the \fIprevClientData\fR argument is NULL then the return +value corresponds to the first (most recently created) matching +trace, or NULL if there are no matching traces. +If the \fIprevClientData\fR argument isn't NULL, then it should +be the return value from a previous call to \fBTcl_VarTraceInfo\fR. +In this case, the new return value will correspond to the next +matching trace after the one whose \fIclientData\fR matches +\fIprevClientData\fR, or NULL if no trace matches \fIprevClientData\fR +or if there are no more matching traces after it. +This mechanism makes it possible to step through all of the +traces for a given variable that have the same \fIproc\fR. + +.SH "TWO-PART NAMES" +.PP +The procedures \fBTcl_TraceVar2\fR, \fBTcl_UntraceVar2\fR, and +\fBTcl_VarTraceInfo2\fR are identical to \fBTcl_TraceVar\fR, +\fBTcl_UntraceVar\fR, and \fBTcl_VarTraceInfo\fR, respectively, +except that the name of the variable has already been +separated by the caller into two parts. +\fIName1\fR gives the name of a scalar variable or array, +and \fIname2\fR gives the name of an element within an +array. +If \fIname2\fR is NULL it means that either the variable is +a scalar or the trace is to be set on the entire array rather +than an individual element (see WHOLE-ARRAY TRACES below for +more information). + +.SH "ACCESSING VARIABLES DURING TRACES" +.PP +During read and write traces, the +trace procedure can read, write, or unset the traced +variable using \fBTcl_GetVar2\fR, \fBTcl_SetVar2\fR, and +other procedures. +While \fIproc\fR is executing, traces are temporarily disabled +for the variable, so that calls to \fBTcl_GetVar2\fR and +\fBTcl_SetVar2\fR will not cause \fIproc\fR or other trace procedures +to be invoked again. +Disabling only occurs for the variable whose trace procedure +is active; accesses to other variables will still be traced. +.VS +However, if a variable is unset during a read or write trace then unset +traces will be invoked. +.VE +.PP +During unset traces the variable has already been completely +expunged. +It is possible for the trace procedure to read or write the +variable, but this will be a new version of the variable. +Traces are not disabled during unset traces as they are for +read and write traces, but existing traces have been removed +from the variable before any trace procedures are invoked. +If new traces are set by unset trace procedures, these traces +will be invoked on accesses to the variable by the trace +procedures. + +.SH "CALLBACK TIMING" +.PP +When read tracing has been specified for a variable, the trace +procedure will be invoked whenever the variable's value is +read. This includes \fBset\fR Tcl commands, \fB$\fR-notation +in Tcl commands, and invocations of the \fBTcl_GetVar\fR +and \fBTcl_GetVar2\fR procedures. +\fIProc\fR is invoked just before the variable's value is +returned. +It may modify the value of the variable to affect what +is returned by the traced access. +.VS +If it unsets the variable then the access will return an error +just as if the variable never existed. +.VE +.PP +When write tracing has been specified for a variable, the +trace procedure will be invoked whenever the variable's value +is modified. This includes \fBset\fR commands\fR, +commands that modify variables as side effects (such as +\fBcatch\fR and \fBscan\fR), and calls to the \fBTcl_SetVar\fR +and \fBTcl_SetVar2\fR procedures). +\fIProc\fR will be invoked after the variable's value has been +modified, but before the new value of the variable has been +returned. +It may modify the value of the variable to override the change +and to determine the value actually returned by the traced +access. +.VS +If it deletes the variable then the traced access will return +an empty string. +.VE +.PP +When unset tracing has been specified, the trace procedure +will be invoked whenever the variable is destroyed. +The traces will be called after the variable has been +completely unset. + +.SH "WHOLE-ARRAY TRACES" +.PP +If a call to \fBTcl_TraceVar\fR or \fBTcl_TraceVar2\fR specifies +the name of an array variable without an index into the array, +then the trace will be set on the array as a whole. +This means that \fIproc\fR will be invoked whenever any +element of the array is accessed in the ways specified by +\fIflags\fR. +When an array is unset, a whole-array trace will be invoked +just once, with \fIname1\fR equal to the name of the array +and \fIname2\fR NULL; it will not be invoked once for each +element. + +.SH "MULTIPLE TRACES" +.PP +It is possible for multiple traces to exist on the same variable. +When this happens, all of the trace procedures will be invoked on each +access, in order from most-recently-created to least-recently-created. +When there exist whole-array traces for an array as well as +traces on individual elements, the whole-array traces are invoked +before the individual-element traces. +.VS +If a read or write trace unsets the variable then all of the unset +traces will be invoked but the remainder of the read and write traces +will be skipped. +.VE + +.SH "ERROR RETURNS" +.PP +Under normal conditions trace procedures should return NULL, indicating +successful completion. +If \fIproc\fR returns a non-NULL value it signifies that an +error occurred. +The return value must be a pointer to a static character string +containing an error message. +If a trace procedure returns an error, no further traces are +invoked for the access and the traced access aborts with the +given message. +Trace procedures can use this facility to make variables +read-only, for example (but note that the value of the variable +will already have been modified before the trace procedure is +called, so the trace procedure will have to restore the correct +value). +.PP +The return value from \fIproc\fR is only used during read and +write tracing. +During unset traces, the return value is ignored and all relevant +trace procedures will always be invoked. + +.SH "RESTRICTIONS" +.PP +A trace procedure can be called at any time, even when there +is a partically-formed result in the interpreter's result area. If +the trace procedure does anything that could damage this result (such +as calling \fBTcl_Eval\fR) then it must save the original values of +the interpreter's \fBresult\fR and \fBfreeProc\fR fields and restore +them before it returns. + +.SH "UNDEFINED VARIABLES" +.PP +It is legal to set a trace on an undefined variable. +The variable will still appear to be undefined until the +first time its value is set. +If an undefined variable is traced and then unset, the unset will fail +with an error (``no such variable''), but the trace +procedure will still be invoked. + +.SH "TCL_TRACE_DELETED FLAG" +.PP +In an unset callback to \fIproc\fR, the TCL_TRACE_DELETED bit +is set in \fIflags\fR if the trace is being removed as part +of the deletion. +Traces on a variable are always removed whenever the variable +is deleted; the only time TCL_TRACE_DELETED isn't set is for +a whole-array trace invoked when only a single element of an +array is unset. + +.SH "TCL_INTERP_DESTROYED" +.PP +When an interpreter is destroyed, unset traces are called for +all of its variables. +The TCL_INTERP_DESTROYED bit will be set in the \fIflags\fR +argument passed to the trace procedures. +Trace procedures must be extremely careful in what they do if +the TCL_INTERP_DESTROYED bit is set. +It is not safe for the procedures to invoke any Tcl procedures +on the interpreter, since its state is partially deleted. +All that trace procedures should do under these circumstances is +to clean up and free their own internal data structures. + +.SH BUGS +.PP +Tcl doesn't do any error checking to prevent trace procedures +from misusing the interpreter during traces with TCL_INTERP_DESTROYED +set. + +.SH KEYWORDS +clientData, trace, variable diff --git a/vendor/x11iraf/obm/Tcl/doc/append.n b/vendor/x11iraf/obm/Tcl/doc/append.n new file mode 100644 index 00000000..7015d5a1 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/doc/append.n @@ -0,0 +1,45 @@ +'\" +'\" Copyright (c) 1993 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 +'\" documentation for any purpose, provided that the above copyright +'\" notice and the following two paragraphs appear in all copies. +'\" +'\" 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 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. +'\" +'\" $Header: /user6/ouster/tcl/man/RCS/append.n,v 1.1 93/04/14 16:52:54 ouster Exp $ SPRITE (Berkeley) +'\" +.so man.macros +.HS append tcl +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +append \- Append to variable +.SH SYNOPSIS +\fBappend \fIvarName value \fR?\fIvalue value ...\fR? +.BE + +.SH DESCRIPTION +.PP +Append all of the \fIvalue\fR arguments to the current value +of variable \fIvarName\fR. If \fIvarName\fR doesn't exist, +it is given a value equal to the concatenation of all the +\fIvalue\fR arguments. +This command provides an efficient way to build up long +variables incrementally. +For example, ``\fBappend a $b\fR'' is much more efficient than +``\fBset a $a$b\fR'' if \fB$a\fR is long. + +.SH KEYWORDS +append, variable diff --git a/vendor/x11iraf/obm/Tcl/doc/array.n b/vendor/x11iraf/obm/Tcl/doc/array.n new file mode 100644 index 00000000..553a1cc9 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/doc/array.n @@ -0,0 +1,95 @@ +'\" +'\" Copyright (c) 1993 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 +'\" documentation for any purpose, provided that the above copyright +'\" notice and the following two paragraphs appear in all copies. +'\" +'\" 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 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. +'\" +'\" $Header: /user6/ouster/tcl/man/RCS/array.n,v 1.1 93/04/14 16:52:55 ouster Exp $ SPRITE (Berkeley) +'\" +.so man.macros +.HS array tcl +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +array \- Manipulate array variables +.SH SYNOPSIS +\fBarray \fIoption arrayName\fR ?\fIarg arg ...\fR? +.BE + +.SH DESCRIPTION +.PP +This command performs one of several operations on the +variable given by \fIarrayName\fR. +\fIArrayName\fR must be the name of an existing array variable. +The \fIoption\fR argument determines what action is carried +out by the command. +The legal \fIoptions\fR (which may be abbreviated) are: +.TP +\fBarray anymore \fIarrayName searchId\fR +Returns 1 if there are any more elements left to be processed +in an array search, 0 if all elements have already been +returned. +\fISearchId\fR indicates which search on \fIarrayName\fR to +check, and must have been the return value from a previous +invocation of \fBarray startsearch\fR. +This option is particularly useful if an array has an element +with an empty name, since the return value from +\fBarray nextelement\fR won't indicate whether the search +has been completed. +.TP +\fBarray donesearch \fIarrayName searchId\fR +This command terminates an array search and destroys all the +state associated with that search. \fISearchId\fR indicates +which search on \fIarrayName\fR to destroy, and must have +been the return value from a previous invocation of +\fBarray startsearch\fR. Returns an empty string. +.TP +\fBarray names \fIarrayName\fR +Returns a list containing the names of all of the elements in +the array. +If there are no elements in the array then an empty string is +returned. +.TP +\fBarray nextelement \fIarrayName searchId\fR +Returns the name of the next element in \fIarrayName\fR, or +an empty string if all elements of \fIarrayName\fR have +already been returned in this search. The \fIsearchId\fR +argument identifies the search, and must have +been the return value of an \fBarray startsearch\fR command. +Warning: if elements are added to or deleted from the array, +then all searches are automatically terminated just as if +\fBarray donesearch\fR had been invoked; this will cause +\fBarray nextelement\fR operations to fail for those searches. +.TP +\fBarray size \fIarrayName\fR +Returns a decimal string giving the number of elements in the +array. +.TP +\fBarray startsearch \fIarrayName\fR +This command initializes an element-by-element search through the +array given by \fIarrayName\fR, such that invocations of the +\fBarray nextelement\fR command will return the names of the +individual elements in the array. +When the search has been completed, the \fBarray donesearch\fR +command should be invoked. +The return value is a +search identifier that must be used in \fBarray nextelement\fR +and \fBarray donesearch\fR commands; it allows multiple +searches to be underway simultaneously for the same array. + +.SH KEYWORDS +array, element names, search diff --git a/vendor/x11iraf/obm/Tcl/doc/break.n b/vendor/x11iraf/obm/Tcl/doc/break.n new file mode 100644 index 00000000..ba2f1088 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/doc/break.n @@ -0,0 +1,41 @@ +'\" +'\" Copyright (c) 1993 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 +'\" documentation for any purpose, provided that the above copyright +'\" notice and the following two paragraphs appear in all copies. +'\" +'\" 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 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. +'\" +'\" $Header: /user6/ouster/tcl/man/RCS/break.n,v 1.1 93/04/14 16:52:56 ouster Exp $ SPRITE (Berkeley) +'\" +.so man.macros +.HS break tcl +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +break \- Abort looping command +.SH SYNOPSIS +\fBbreak\fR +.BE + +.SH DESCRIPTION +.PP +This command may be invoked only inside the body of a looping command +such as \fBfor\fR or \fBforeach\fR or \fBwhile\fR. +It returns a TCL_BREAK code to signal the innermost containing +loop command to return immediately. + +.SH KEYWORDS +abort, break, loop diff --git a/vendor/x11iraf/obm/Tcl/doc/case.n b/vendor/x11iraf/obm/Tcl/doc/case.n new file mode 100644 index 00000000..79114343 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/doc/case.n @@ -0,0 +1,72 @@ +'\" +'\" Copyright (c) 1993 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 +'\" documentation for any purpose, provided that the above copyright +'\" notice and the following two paragraphs appear in all copies. +'\" +'\" 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 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. +'\" +'\" $Header: /user6/ouster/tcl/man/RCS/case.n,v 1.3 93/06/17 11:29:59 ouster Exp $ SPRITE (Berkeley) +'\" +.so man.macros +.HS case tcl 7.0 +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +case \- Evaluate one of several scripts, depending on a given value +.SH SYNOPSIS +\fBcase\fI string \fR?\fBin\fR? \fIpatList body \fR?\fIpatList body \fR...? +.br +\fBcase\fI string \fR?\fBin\fR? {\fIpatList body \fR?\fIpatList body \fR...?} +.BE + +.SH DESCRIPTION +.PP +\fINote: the \fBcase\fI command is obsolete and is supported only +for backward compatibility. At some point in the future it may be +removed entirely. You should use the \fBswitch\fI command instead.\fR +.PP +The \fBcase\fR command matches \fIstring\fR against each of +the \fIpatList\fR arguments in order. +Each \fIpatList\fR argument is a list of one or +more patterns. If any of these patterns matches \fIstring\fR then +\fBcase\fR evaluates the following \fIbody\fR argument +by passing it recursively to the Tcl interpreter and returns the result +of that evaluation. +Each \fIpatList\fR argument consists of a single +pattern or list of patterns. Each pattern may contain any of the wild-cards +described under \fBstring match\fR. If a \fIpatList\fR +argument is \fBdefault\fR, the corresponding body will be evaluated +if no \fIpatList\fR matches \fIstring\fR. If no \fIpatList\fR argument +matches \fIstring\fR and no default is given, then the \fBcase\fR +command returns an empty string. +.PP +Two syntaxes are provided for the \fIpatList\fR and \fIbody\fR arguments. +The first uses a separate argument for each of the patterns and commands; +this form is convenient if substitutions are desired on some of the +patterns or commands. +The second form places all of the patterns and commands together into +a single argument; the argument must have proper list structure, with +the elements of the list being the patterns and commands. +The second form makes it easy to construct multi-line case commands, +since the braces around the whole list make it unnecessary to include a +backslash at the end of each line. +Since the \fIpatList\fR arguments are in braces in the second form, +no command or variable substitutions are performed on them; this makes +the behavior of the second form different than the first form in some +cases. + +.SH KEYWORDS +case, match, regular expression diff --git a/vendor/x11iraf/obm/Tcl/doc/catch.n b/vendor/x11iraf/obm/Tcl/doc/catch.n new file mode 100644 index 00000000..735aba0d --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/doc/catch.n @@ -0,0 +1,50 @@ +'\" +'\" Copyright (c) 1993 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 +'\" documentation for any purpose, provided that the above copyright +'\" notice and the following two paragraphs appear in all copies. +'\" +'\" 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 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. +'\" +'\" $Header: /user6/ouster/tcl/man/RCS/catch.n,v 1.1 93/04/14 16:52:57 ouster Exp $ SPRITE (Berkeley) +'\" +.so man.macros +.HS catch tcl +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +catch \- Evaluate script and trap exceptional returns +.SH SYNOPSIS +\fBcatch\fI script \fR?\fIvarName\fR? +.BE + +.SH DESCRIPTION +.PP +The \fBcatch\fR command may be used to prevent errors from aborting +command interpretation. \fBCatch\fR calls the Tcl interpreter recursively +to execute \fIscript\fR, and always returns a TCL_OK code, regardless of +any errors that might occur while executing \fIscript\fR. The return +value from \fBcatch\fR is a decimal string giving the +code returned by the Tcl interpreter after executing \fIscript\fR. +This will be \fB0\fR (TCL_OK) if there were no errors in \fIscript\fR; +otherwise +it will have a non-zero value corresponding to one of the exceptional +return codes (see tcl.h for the definitions of code values). If the +\fIvarName\fR argument is given, then it gives the name of a variable; +\fBcatch\fR will set the variable to the string returned +from \fIscript\fR (either a result or an error message). + +.SH KEYWORDS +catch, error diff --git a/vendor/x11iraf/obm/Tcl/doc/cd.n b/vendor/x11iraf/obm/Tcl/doc/cd.n new file mode 100644 index 00000000..cfc4401a --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/doc/cd.n @@ -0,0 +1,43 @@ +'\" +'\" Copyright (c) 1993 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 +'\" documentation for any purpose, provided that the above copyright +'\" notice and the following two paragraphs appear in all copies. +'\" +'\" 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 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. +'\" +'\" $Header: /user6/ouster/tcl/man/RCS/cd.n,v 1.1 93/04/14 16:52:58 ouster Exp $ SPRITE (Berkeley) +'\" +.so man.macros +.HS cd tcl +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +cd \- Change working directory +.SH SYNOPSIS +\fBcd \fR?\fIdirName\fR? +.BE + +.SH DESCRIPTION +.PP +Change the current working directory to \fIdirName\fR, or to the +home directory (as specified in the HOME environment variable) if +\fIdirName\fR is not given. +If \fIdirName\fR starts with a tilde, then tilde-expansion is +done as described for \fBTcl_TildeSubst\fR. +Returns an empty string. + +.SH KEYWORDS +working directory diff --git a/vendor/x11iraf/obm/Tcl/doc/close.n b/vendor/x11iraf/obm/Tcl/doc/close.n new file mode 100644 index 00000000..dbd0dc0e --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/doc/close.n @@ -0,0 +1,46 @@ +'\" +'\" Copyright (c) 1993 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 +'\" documentation for any purpose, provided that the above copyright +'\" notice and the following two paragraphs appear in all copies. +'\" +'\" 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 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. +'\" +'\" $Header: /user6/ouster/tcl/man/RCS/close.n,v 1.1 93/04/16 17:23:28 ouster Exp $ SPRITE (Berkeley) +'\" +.so man.macros +.HS close tcl +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +close \- Close an open file +.SH SYNOPSIS +\fBclose \fIfileId\fR +.BE + +.SH DESCRIPTION +.PP +Closes the file given by \fIfileId\fR. +\fIFileId\fR must be the return value from a previous invocation +of the \fBopen\fR command; after this command, it should not be +used anymore. +If \fIfileId\fR refers to a command pipeline instead of a file, +then \fBclose\fR waits for the children to complete. +The normal result of this command is an empty string, but errors +are returned if there are problems in closing the file or waiting +for children to complete. + +.SH KEYWORDS +close, file diff --git a/vendor/x11iraf/obm/Tcl/doc/concat.n b/vendor/x11iraf/obm/Tcl/doc/concat.n new file mode 100644 index 00000000..8b50e327 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/doc/concat.n @@ -0,0 +1,57 @@ +'\" +'\" Copyright (c) 1993 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 +'\" documentation for any purpose, provided that the above copyright +'\" notice and the following two paragraphs appear in all copies. +'\" +'\" 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 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. +'\" +'\" $Header: /user6/ouster/tcl/man/RCS/concat.n,v 1.2 93/10/28 16:19:07 ouster Exp $ SPRITE (Berkeley) +'\" +.so man.macros +.HS concat tcl +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +concat \- Join lists together +.SH SYNOPSIS +.VS +\fBconcat\fI \fR?\fIarg arg ...\fR? +.VE +.BE + +.SH DESCRIPTION +.PP +This command treats each argument as a list and concatenates them +into a single list. +It also eliminates leading and trailing spaces in the \fIarg\fR's +and adds a single separator space between \fIarg\fR's. +It permits any number of arguments. For example, +the command +.DS +\fBconcat a b {c d e} {f {g h}}\fR +.DE +will return +.DS +\fBa b c d e f {g h}\fR +.DE +as its result. +.PP +.VS +If no \fIarg\fRs are supplied, the result is an empty string. +.VE + +.SH KEYWORDS +concatenate, join, lists diff --git a/vendor/x11iraf/obm/Tcl/doc/continue.n b/vendor/x11iraf/obm/Tcl/doc/continue.n new file mode 100644 index 00000000..90adf49e --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/doc/continue.n @@ -0,0 +1,43 @@ +'\" +'\" Copyright (c) 1993 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 +'\" documentation for any purpose, provided that the above copyright +'\" notice and the following two paragraphs appear in all copies. +'\" +'\" 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 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. +'\" +'\" $Header: /user6/ouster/tcl/man/RCS/continue.n,v 1.1 93/04/16 17:23:30 ouster Exp $ SPRITE (Berkeley) +'\" +.so man.macros +.HS continue tcl +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +continue \- Skip to the next iteration of a loop +.SH SYNOPSIS +\fBcontinue\fR +.BE + +.SH DESCRIPTION +.PP +This command may be invoked only inside the body of a looping command +such as \fBfor\fR or \fBforeach\fR or \fBwhile\fR. +It returns a TCL_CONTINUE code +to signal the innermost containing loop command to skip the +remainder of the loop's body +but continue with the next iteration of the loop. + +.SH KEYWORDS +continue, iteration, loop diff --git a/vendor/x11iraf/obm/Tcl/doc/eof.n b/vendor/x11iraf/obm/Tcl/doc/eof.n new file mode 100644 index 00000000..ef6e7660 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/doc/eof.n @@ -0,0 +1,43 @@ +'\" +'\" Copyright (c) 1993 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 +'\" documentation for any purpose, provided that the above copyright +'\" notice and the following two paragraphs appear in all copies. +'\" +'\" 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 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. +'\" +'\" $Header: /user6/ouster/tcl/man/RCS/eof.n,v 1.1 93/04/16 17:23:31 ouster Exp $ SPRITE (Berkeley) +'\" +.so man.macros +.HS eof tcl +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +eof \- Check for end-of-file condition on open file +.SH SYNOPSIS +\fBeof \fIfileId\fR +.BE + +.SH DESCRIPTION +.PP +Returns 1 if an end-of-file condition has occurred on \fIfileId\fR, +0 otherwise. +\fIFileId\fR must have been the return +value from a previous call to \fBopen\fR, or it may be \fBstdin\fR, +\fBstdout\fR, or \fBstderr\fR to refer to one of the standard I/O +channels. + +.SH KEYWORDS +end, file diff --git a/vendor/x11iraf/obm/Tcl/doc/error.n b/vendor/x11iraf/obm/Tcl/doc/error.n new file mode 100644 index 00000000..0c901153 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/doc/error.n @@ -0,0 +1,71 @@ +'\" +'\" Copyright (c) 1993 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 +'\" documentation for any purpose, provided that the above copyright +'\" notice and the following two paragraphs appear in all copies. +'\" +'\" 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 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. +'\" +'\" $Header: /user6/ouster/tcl/man/RCS/error.n,v 1.1 93/04/16 17:23:32 ouster Exp $ SPRITE (Berkeley) +'\" +.so man.macros +.HS error tcl +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +error \- Generate an error +.SH SYNOPSIS +\fBerror \fImessage\fR ?\fIinfo\fR? ?\fIcode\fR? +.BE + +.SH DESCRIPTION +.PP +Returns a TCL_ERROR code, which causes command interpretation to be +unwound. \fIMessage\fR is a string that is returned to the application +to indicate what went wrong. +.PP +If the \fIinfo\fR argument is provided and is non-empty, +it is used to initialize the global variable \fBerrorInfo\fR. +\fBerrorInfo\fR is used to accumulate a stack trace of what +was in progress when an error occurred; as nested commands unwind, +the Tcl interpreter adds information to \fBerrorInfo\fR. If the +\fIinfo\fR argument is present, it is used to initialize +\fBerrorInfo\fR and the first increment of unwind information +will not be added by the Tcl interpreter. In other +words, the command containing the \fBerror\fR command will not appear +in \fBerrorInfo\fR; in its place will be \fIinfo\fR. +This feature is most useful in conjunction with the \fBcatch\fR command: +if a caught error cannot be handled successfully, \fIinfo\fR can be used +to return a stack trace reflecting the original point of occurrence +of the error: +.DS +\fBcatch {...} errMsg +set savedInfo $errorInfo +\&... +error $errMsg $savedInfo\fR +.DE +.PP +If the \fIcode\fR argument is present, then its value is stored +in the \fBerrorCode\fR global variable. This variable is intended +to hold a machine-readable description of the error in cases where +such information is available; see the section BUILT-IN VARIABLES +below for information on the proper format for the variable. +If the \fIcode\fR argument is not +present, then \fBerrorCode\fR is automatically reset to +``NONE'' by the Tcl interpreter as part of processing the +error generated by the command. + +.SH KEYWORDS +error, errorCode, errorInfo diff --git a/vendor/x11iraf/obm/Tcl/doc/eval.n b/vendor/x11iraf/obm/Tcl/doc/eval.n new file mode 100644 index 00000000..7c38ab4c --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/doc/eval.n @@ -0,0 +1,43 @@ +'\" +'\" Copyright (c) 1993 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 +'\" documentation for any purpose, provided that the above copyright +'\" notice and the following two paragraphs appear in all copies. +'\" +'\" 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 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. +'\" +'\" $Header: /user6/ouster/tcl/man/RCS/eval.n,v 1.1 93/05/10 17:10:16 ouster Exp $ SPRITE (Berkeley) +'\" +.so man.macros +.HS eval tcl +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +eval \- Evaluate a Tcl script +.SH SYNOPSIS +\fBeval \fIarg \fR?\fIarg ...\fR? +.BE + +.SH DESCRIPTION +.PP +\fBEval\fR takes one or more arguments, which together comprise a Tcl +script containing one or more commands. +\fBEval\fR concatenates all its arguments in the same +fashion as the \fBconcat\fR command, passes the concatenated string to the +Tcl interpreter recursively, and returns the result of that +evaluation (or any error generated by it). + +.SH KEYWORDS +concatenate, evaluate, script diff --git a/vendor/x11iraf/obm/Tcl/doc/exec.n b/vendor/x11iraf/obm/Tcl/doc/exec.n new file mode 100644 index 00000000..fa900616 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/doc/exec.n @@ -0,0 +1,198 @@ +'\" +'\" Copyright (c) 1993 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 +'\" documentation for any purpose, provided that the above copyright +'\" notice and the following two paragraphs appear in all copies. +'\" +'\" 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 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. +'\" +'\" $Header: /user6/ouster/tcl/man/RCS/exec.n,v 1.6 93/07/23 15:13:34 ouster Exp $ SPRITE (Berkeley) +'\" +.so man.macros +.HS exec tcl 7.0 +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +exec \- Invoke subprocess(es) +.SH SYNOPSIS +\fBexec \fR?\fIswitches\fR? \fIarg \fR?\fIarg ...\fR? +.BE + +.SH DESCRIPTION +.PP +This command treats its arguments as the specification +of one or more subprocesses to execute. +The arguments take the form of a standard shell pipeline +where each \fIarg\fR becomes one word of a command, and +each distinct command becomes a subprocess. +.PP +If the initial arguments to \fBexec\fR start with \fB\-\fR then +.VS +they are treated as command-line switches and are not part +of the pipeline specification. The following switches are +currently supported: +.TP 13 +\fB\-keepnewline +Retains a trailing newline in the pipeline's output. +Normally a trailing newline will be deleted. +.TP 13 +\fB\-\|\-\fR +Marks the end of switches. The argument following this one will +be treated as the first \fIarg\fR even if it starts with a \fB\-. +.VE +.PP +If an \fIarg\fR (or pair of \fIarg\fR's) has one of the forms +described below then it is used by \fBexec\fR to control the +flow of input and output among the subprocess(es). +Such arguments will not be passed to the subprocess(es). In forms +.VS +such as ``< \fIfileName\fR'' \fIfileName\fR may either be in a +separate argument from ``<'' or in the same argument with no +intervening space (i.e. ``<\fIfileName\fR''). +.VE +.TP 15 +|\fR +Separates distinct commands in the pipeline. The standard output +of the preceding command will be piped into the standard input +of the next command. +.TP 15 +|&\fR +Separates distinct commands in the pipeline. Both standard output +and standard error of the preceding command will be piped into +the standard input of the next command. +This form of redirection overrides forms such as 2> and >&. +.TP 15 +<\0\fIfileName\fR +The file named by \fIfileName\fR is opened and used as the standard +input for the first command in the pipeline. +.TP 15 +<@\0\fIfileId\fR +.VS +\fIFileId\fR must be the identifier for an open file, such as the return +value from a previous call to \fBopen\fR. +It is used as the standard input for the first command in the pipeline. +\fIFileId\fR must have been opened for reading. +.VE +.TP 15 +<<\0\fIvalue\fR +\fIValue\fR is passed to the first command as its standard input. +.TP 15 +>\0\fIfileName\fR +Standard output from the last command is redirected to the file named +\fIfileName\fR, overwriting its previous contents. +.TP 15 +2>\0\fIfileName\fR +.VS +Standard error from all commands in the pipeline is redirected to the +file named \fIfileName\fR, overwriting its previous contents. +.TP 15 +>&\0\fIfileName\fR +Both standard output from the last command and standard error from all +commands are redirected to the file named \fIfileName\fR, overwriting +its previous contents. +.VE +.TP 15 +>>\0\fIfileName\fR +Standard output from the last command is +redirected to the file named \fIfileName\fR, appending to it rather +than overwriting it. +.TP 15 +2>>\0\fIfileName\fR +.VS +Standard error from all commands in the pipeline is +redirected to the file named \fIfileName\fR, appending to it rather +than overwriting it. +.TP 15 +>>&\0\fIfileName\fR +Both standard output from the last command and standard error from +all commands are redirected to the file named \fIfileName\fR, +appending to it rather than overwriting it. +.TP 15 +>@\0\fIfileId\fR +\fIFileId\fR must be the identifier for an open file, such as the return +value from a previous call to \fBopen\fR. +Standard output from the last command is redirected to \fIfileId\fR's +file, which must have been opened for writing. +.TP 15 +2>@\0\fIfileId\fR +\fIFileId\fR must be the identifier for an open file, such as the return +value from a previous call to \fBopen\fR. +Standard error from all commands in the pipeline is +redirected to \fIfileId\fR's file. +The file must have been opened for writing. +.TP 15 +>&@\0\fIfileId\fR +\fIFileId\fR must be the identifier for an open file, such as the return +value from a previous call to \fBopen\fR. +Both standard output from the last command and standard error from +all commands are redirected to \fIfileId\fR's file. +The file must have been opened for writing. +.VE +.PP +If standard output has not been redirected then the \fBexec\fR +command returns the standard output from the last command +in the pipeline. +If any of the commands in the pipeline exit abnormally or +are killed or suspended, then \fBexec\fR will return an error +and the error message will include the pipeline's output followed by +error messages describing the abnormal terminations; the +\fBerrorCode\fR variable will contain additional information +about the last abnormal termination encountered. +If any of the commands writes to its standard error file and that +standard error isn't redirected, +then \fBexec\fR will return an error; the error message +will include the pipeline's standard output, followed by messages +about abnormal terminations (if any), followed by the standard error +output. +.PP +If the last character of the result or error message +is a newline then that character is normally deleted +from the result or error message. +This is consistent with other Tcl return values, which don't +normally end with newlines. +.VS +However, if \fB\-keepnewline\fR is specified then the trailing +newline is retained. +.VE +.PP +If standard input isn't redirected with ``<'' or ``<<'' +or ``<@'' then the standard input for the first command in the +pipeline is taken from the application's current standard input. +.PP +If the last \fIarg\fR is ``&'' then the pipeline will be +executed in background. +.VS +In this case the \fBexec\fR command will return a list whose +elements are the process identifiers for all of the subprocesses +in the pipeline. +.VE +The standard output from the last command in the pipeline will +go to the application's standard output if it hasn't been +redirected, and error output from all of +the commands in the pipeline will go to the application's +standard error file unless redirected. +.PP +The first word in each command is taken as the command name; +tilde-substitution is performed on it, and if the result contains +no slashes then the directories +in the PATH environment variable are searched for +an executable by the given name. +If the name contains a slash then it must refer to an executable +reachable from the current directory. +No ``glob'' expansion or other shell-like substitutions +are performed on the arguments to commands. + +.SH KEYWORDS +execute, pipeline, redirection, subprocess diff --git a/vendor/x11iraf/obm/Tcl/doc/exit.n b/vendor/x11iraf/obm/Tcl/doc/exit.n new file mode 100644 index 00000000..d25a524a --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/doc/exit.n @@ -0,0 +1,41 @@ +'\" +'\" Copyright (c) 1993 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 +'\" documentation for any purpose, provided that the above copyright +'\" notice and the following two paragraphs appear in all copies. +'\" +'\" 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 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. +'\" +'\" $Header: /user6/ouster/tcl/man/RCS/exit.n,v 1.2 93/06/17 13:31:30 ouster Exp $ SPRITE (Berkeley) +'\" +.so man.macros +.HS exit tcl +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +exit \- End the application +.SH SYNOPSIS +\fBexit \fR?\fIreturnCode\fR? +.BE + +.SH DESCRIPTION +.PP +Terminate the process, returning \fIreturnCode\fR to the +system as the exit status. +If \fIreturnCode\fR isn't specified then it defaults +to 0. + +.SH KEYWORDS +exit, process diff --git a/vendor/x11iraf/obm/Tcl/doc/expr.n b/vendor/x11iraf/obm/Tcl/doc/expr.n new file mode 100644 index 00000000..957d8cc0 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/doc/expr.n @@ -0,0 +1,302 @@ +'\" +'\" Copyright (c) 1993 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 +'\" documentation for any purpose, provided that the above copyright +'\" notice and the following two paragraphs appear in all copies. +'\" +'\" 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 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. +'\" +'\" $Header: /user6/ouster/tcl/man/RCS/expr.n,v 1.5 93/09/02 16:41:26 ouster Exp $ SPRITE (Berkeley) +'\" +.so man.macros +.HS expr tcl 7.0 +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +expr \- Evalue an expression +.SH SYNOPSIS +\fBexpr \fIarg \fR?\fIarg arg ...\fR? +.BE + +.SH DESCRIPTION +.PP +.VS +Concatenates \fIarg\fR's (adding separator spaces between them), +evaluates the result as a Tcl expression, and returns the value. +.VE +The operators permitted in Tcl expressions are a subset of +the operators permitted in C expressions, and they have the +same meaning and precedence as the corresponding C operators. +Expressions almost always yield numeric results +(integer or floating-point values). +For example, the expression +.DS +\fBexpr 8.2 + 6\fR +.DE +evaluates to 14.2. +Tcl expressions differ from C expressions in the way that +operands are specified. Also, Tcl expressions support +non-numeric operands and string comparisons. +.SH OPERANDS +.PP +A Tcl expression consists of a combination of operands, operators, +and parentheses. +White space may be used between the operands and operators and +parentheses; it is ignored by the expression processor. +Where possible, operands are interpreted as integer values. +Integer values may be specified in decimal (the normal case), in octal (if the +first character of the operand is \fB0\fR), or in hexadecimal (if the first +two characters of the operand are \fB0x\fR). +If an operand does not have one of the integer formats given +above, then it is treated as a floating-point number if that is +possible. Floating-point numbers may be specified in any of the +ways accepted by an ANSI-compliant C compiler (except that the +``f'', ``F'', ``l'', and ``L'' suffixes will not be permitted in +most installations). For example, all of the +following are valid floating-point numbers: 2.1, 3., 6e4, 7.91e+16. +If no numeric interpretation is possible, then an operand is left +as a string (and only a limited set of operators may be applied to +it). +.PP +Operands may be specified in any of the following ways: +.IP [1] +As an numeric value, either integer or floating-point. +.IP [2] +As a Tcl variable, using standard \fB$\fR notation. +The variable's value will be used as the operand. +.IP [3] +As a string enclosed in double-quotes. +The expression parser will perform backslash, variable, and +command substitutions on the information between the quotes, +and use the resulting value as the operand +.IP [4] +As a string enclosed in braces. +The characters between the open brace and matching close brace +will be used as the operand without any substitutions. +.IP [5] +As a Tcl command enclosed in brackets. +The command will be executed and its result will be used as +the operand. +.IP [6] +.VS +As a mathematical function whose arguments have any of the above +forms for operands, such as ``\fBsin($x)\fR''. See below for a list of defined +functions. +.VE +.LP +Where substitutions occur above (e.g. inside quoted strings), they +are performed by the expression processor. +However, an additional layer of substitution may already have +been performed by the command parser before the expression +processor was called. +As discussed below, it is usually best to enclose expressions +in braces to prevent the command parser from performing substitutions +on the contents. +.PP +For some examples of simple expressions, suppose the variable +\fBa\fR has the value 3 and +the variable \fBb\fR has the value 6. +Then the command on the left side of each of the lines below +will produce the value on the right side of the line: +.DS +.ta 6c +\fBexpr 3.1 + $a 6.1 +expr 2 + "$a.$b" 5.6 +expr 4*[llength "6 2"] 8 +expr {{word one} < "word $a"} 0\fR +.DE +.SH OPERATORS +.PP +The valid operators are listed below, grouped in decreasing order +of precedence: +.TP 20 +\fB\-\0\0~\0\0!\fR +Unary minus, bit-wise NOT, logical NOT. None of these operands +may be applied to string operands, and bit-wise NOT may be +applied only to integers. +.TP 20 +\fB*\0\0/\0\0%\fR +Multiply, divide, remainder. None of these operands may be +applied to string operands, and remainder may be applied only +to integers. +.VS +The remainder will always have the same sign as the divisor and +an absolute value smaller than the divisor. +.VE +.TP 20 +\fB+\0\0\-\fR +Add and subtract. Valid for any numeric operands. +.TP 20 +\fB<<\0\0>>\fR +Left and right shift. Valid for integer operands only. +.TP 20 +\fB<\0\0>\0\0<=\0\0>=\fR +Boolean less, greater, less than or equal, and greater than or equal. +Each operator produces 1 if the condition is true, 0 otherwise. +These operators may be applied to strings as well as numeric operands, +in which case string comparison is used. +.TP 20 +\fB==\0\0!=\fR +Boolean equal and not equal. Each operator produces a zero/one result. +Valid for all operand types. +.TP 20 +\fB&\fR +Bit-wise AND. Valid for integer operands only. +.TP 20 +\fB^\fR +Bit-wise exclusive OR. Valid for integer operands only. +.TP 20 +\fB|\fR +Bit-wise OR. Valid for integer operands only. +.TP 20 +\fB&&\fR +Logical AND. Produces a 1 result if both operands are non-zero, 0 otherwise. +Valid for numeric operands only (integers or floating-point). +.TP 20 +\fB||\fR +Logical OR. Produces a 0 result if both operands are zero, 1 otherwise. +Valid for numeric operands only (integers or floating-point). +.TP 20 +\fIx\fB?\fIy\fB:\fIz\fR +If-then-else, as in C. If \fIx\fR +evaluates to non-zero, then the result is the value of \fIy\fR. +Otherwise the result is the value of \fIz\fR. +The \fIx\fR operand must have a numeric value. +.LP +See the C manual for more details on the results +produced by each operator. +All of the binary operators group left-to-right within the same +precedence level. For example, the command +.DS +\fBexpr 4*2 < 7\fR +.DE +returns 0. +.PP +The \fB&&\fP, \fB||\fP, and \fB?:\fP operators have ``lazy +evaluation'', just as in C, +which means that operands are not evaluated if they are +not needed to determine the outcome. For example, in the command +.DS +\fBexpr {$v ? [a] : [b]}\fR +.DE +only one of \fB[a]\fR or \fB[b]\fR will actually be evaluated, +depending on the value of \fB$v\fP. Note, however, that this is +only true if the entire expression is enclosed in braces; otherwise +the Tcl parser will evaluate both \fB[a]\fR and \fB[b]\fR before +invoking the \fBexpr\fR command. +.SH "MATH FUNCTIONS" +.PP +.VS +Tcl supports the following mathematical functions in expressions: +.DS +.ta 3c 6c 9c +\fBacos\fR \fBcos\fR \fBhypot\fR \fBsinh\fR +\fBasin\fR \fBcosh\fR \fBlog\fR \fBsqrt\fR +\fBatan\fR \fBexp\fR \fBlog10\fR \fBtan\fR +\fBatan2\fR \fBfloor\fR \fBpow\fR \fBtanh\fR +\fBceil\fR \fBfmod\fR \fBsin\fR +.DE +Each of these functions invokes the math library function of the same +name; see the manual entries for the library functions for details +on what they do. Tcl also implements the following functions for +conversion between integers and floating-point numbers: +.TP +\fBabs(\fIarg\fB)\fI +Returns the absolute value of \fIarg\fR. \fIArg\fR may be either +integer or floating-point, and the result is returned in the same form. +.TP +\fBdouble(\fIarg\fB)\fR +If \fIarg\fR is a floating value, returns \fIarg\fR, otherwise converts +\fIarg\fR to floating and returns the converted value. +.TP +\fBint(\fIarg\fB)\fR +If \fIarg\fR is an integer value, returns \fIarg\fR, otherwise converts +\fIarg\fR to integer by truncation and returns the converted value. +.TP +\fBround(\fIarg\fB)\fR +If \fIarg\fR is an integer value, returns \fIarg\fR, otherwise converts +\fIarg\fR to integer by rounding and returns the converted value. +.PP +In addition to these predifined functions, applications may +define additional functions using \fBTcl_CreateMathFunc\fR(). +.VE +.SH "TYPES, OVERFLOW, AND PRECISION" +.PP +All internal computations involving integers are done with the C type +\fIlong\fP, and all internal computations involving floating-point are +done with the C type \fIdouble\fP. +When converting a string to floating-point, exponent overflow is +detected and results in a Tcl error. +For conversion to integer from string, detection of overflow depends +on the behavior of some routines in the local C library, so it should +be regarded as unreliable. +In any case, integer overflow and underflow are generally not detected +reliably for intermediate results. Floating-point overflow and underflow +are detected to the degree supported by the hardware, which is generally +pretty reliable. +.PP +Conversion among internal representations for integer, floating-point, +and string operands is done automatically as needed. +For arithmetic computations, integers are used until some +floating-point number is introduced, after which floating-point is used. +For example, +.DS +\fBexpr 5 / 4\fR +.DE +returns 1, while +.DS +\fBexpr 5 / 4.0\fR +\fBexpr 5 / ( [string length "abcd"] + 0.0 ) +.DE +both return 1.25. +.VS +Floating-point values are always returned with a ``.'' +or an ``e'' so that they will not look like integer values. For +example, +.DS +\fBexpr 20.0/5.0\fR +.DE +returns ``4.0'', not ``4''. The global variable \fBtcl_precision\fR +determines the the number of significant digits that are retained +when floating values are converted to strings (except that trailing +zeroes are omitted). If \fBtcl_precision\fR +is unset then 6 digits of precision are used. +To retain all of the significant bits of an IEEE floating-point +number set \fBtcl_precision\fR to 17; if a value is converted to +string with 17 digits of precision and then converted back to binary +for some later calculation, the resulting binary value is guaranteed +to be identical to the original one. +.VE + +.SH "STRING OPERATIONS" +.PP +String values may be used as operands of the comparison operators, +although the expression evaluator tries to do comparisons as integer +or floating-point when it can. +If one of the operands of a comparison is a string and the other +has a numeric value, the numeric operand is converted back to +a string using the C \fIsprintf\fP format specifier +\fB%d\fR for integers and \fB%g\fR for floating-point values. +For example, the commands +.DS +\fBexpr {"0x03" > "2"}\fR +\fBexpr {"0y" < "0x12"}\fR +.DE +both return 1. The first comparison is done using integer +comparison, and the second is done using string comparison after +the second operand is converted to the string ``18''. + +.SH KEYWORDS +arithmetic, boolean, compare, expression diff --git a/vendor/x11iraf/obm/Tcl/doc/file.n b/vendor/x11iraf/obm/Tcl/doc/file.n new file mode 100644 index 00000000..2423daea --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/doc/file.n @@ -0,0 +1,146 @@ +'\" +'\" Copyright (c) 1993 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 +'\" documentation for any purpose, provided that the above copyright +'\" notice and the following two paragraphs appear in all copies. +'\" +'\" 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 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. +'\" +'\" $Header: /user6/ouster/tcl/man/RCS/file.n,v 1.1 93/05/03 17:09:38 ouster Exp $ SPRITE (Berkeley) +'\" +.so man.macros +.HS file tcl +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +file \- Manipulate file names and attributes +.SH SYNOPSIS +\fBfile \fIoption\fR \fIname\fR ?\fIarg arg ...\fR? +.BE + +.SH DESCRIPTION +.PP +This command provides several operations on a file's name or attributes. +\fIName\fR is the name of a file; +if it starts with a tilde, then tilde substitution is done before +executing the command (see the manual entry for \fBTcl_TildeSubst\fR +for details). +\fIOption\fR indicates what to do with the file name. Any unique +abbreviation for \fIoption\fR is acceptable. The valid options are: +.TP +\fBfile \fBatime \fIname\fR +Returns a decimal string giving the time at which file \fIname\fR +was last accessed. The time is measured in the standard POSIX +fashion as seconds from a fixed starting time (often January 1, 1970). +If the file doesn't exist or its access time cannot be queried then an +error is generated. +.TP +\fBfile \fBdirname \fIname\fR +Returns all of the characters in \fIname\fR up to but not including +the last slash character. If there are no slashes in \fIname\fR +then returns ``.''. If the last slash in \fIname\fR is its first +character, then return ``/''. +.TP +\fBfile \fBexecutable \fIname\fR +Returns \fB1\fR if file \fIname\fR is executable by +the current user, \fB0\fR otherwise. +.TP +\fBfile \fBexists \fIname\fR +Returns \fB1\fR if file \fIname\fR exists and the current user has +search privileges for the directories leading to it, \fB0\fR otherwise. +.TP +\fBfile \fBextension \fIname\fR +Returns all of the characters in \fIname\fR after and including the +last dot in \fIname\fR. If there is no dot in \fIname\fR then returns +the empty string. +.TP +\fBfile \fBisdirectory \fIname\fR +Returns \fB1\fR if file \fIname\fR is a directory, +\fB0\fR otherwise. +.TP +\fBfile \fBisfile \fIname\fR +Returns \fB1\fR if file \fIname\fR is a regular file, +\fB0\fR otherwise. +.TP +\fBfile lstat \fIname varName\fR +Same as \fBstat\fR option (see below) except uses the \fIlstat\fR +kernel call instead of \fIstat\fR. This means that if \fIname\fR +refers to a symbolic link the information returned in \fIvarName\fR +is for the link rather than the file it refers to. On systems that +don't support symbolic links this option behaves exactly the same +as the \fBstat\fR option. +.TP +\fBfile \fBmtime \fIname\fR +Returns a decimal string giving the time at which file \fIname\fR +was last modified. The time is measured in the standard POSIX +fashion as seconds from a fixed starting time (often January 1, 1970). +If the file doesn't exist or its modified time cannot be queried then an +error is generated. +.TP +\fBfile \fBowned \fIname\fR +Returns \fB1\fR if file \fIname\fR is owned by the current user, +\fB0\fR otherwise. +.TP +\fBfile \fBreadable \fIname\fR +Returns \fB1\fR if file \fIname\fR is readable by +the current user, \fB0\fR otherwise. +.TP +\fBfile readlink \fIname\fR +Returns the value of the symbolic link given by \fIname\fR (i.e. the +name of the file it points to). If +\fIname\fR isn't a symbolic link or its value cannot be read, then +an error is returned. On systems that don't support symbolic links +this option is undefined. +.TP +\fBfile \fBrootname \fIname\fR +Returns all of the characters in \fIname\fR up to but not including +the last ``.'' character in the name. If \fIname\fR doesn't contain +a dot, then returns \fIname\fR. +.TP +\fBfile \fBsize \fIname\fR +Returns a decimal string giving the size of file \fIname\fR in bytes. +If the file doesn't exist or its size cannot be queried then an +error is generated. +.TP +\fBfile \fBstat \fIname varName\fR +Invokes the \fBstat\fR kernel call on \fIname\fR, and uses the +variable given by \fIvarName\fR to hold information returned from +the kernel call. +\fIVarName\fR is treated as an array variable, +and the following elements of that variable are set: \fBatime\fR, +\fBctime\fR, \fBdev\fR, \fBgid\fR, \fBino\fR, \fBmode\fR, \fBmtime\fR, +\fBnlink\fR, \fBsize\fR, \fBtype\fR, \fBuid\fR. +Each element except \fBtype\fR is a decimal string with the value of +the corresponding field from the \fBstat\fR return structure; see the +manual entry for \fBstat\fR for details on the meanings of the values. +The \fBtype\fR element gives the type of the file in the same form +returned by the command \fBfile type\fR. +This command returns an empty string. +.TP +\fBfile \fBtail \fIname\fR +Returns all of the characters in \fIname\fR after the last slash. +If \fIname\fR contains no slashes then returns \fIname\fR. +.TP +\fBfile \fBtype \fIname\fR +Returns a string giving the type of file \fIname\fR, which will be +one of \fBfile\fR, \fBdirectory\fR, \fBcharacterSpecial\fR, +\fBblockSpecial\fR, \fBfifo\fR, \fBlink\fR, or \fBsocket\fR. +.TP +\fBfile \fBwritable \fIname\fR +Returns \fB1\fR if file \fIname\fR is writable by +the current user, \fB0\fR otherwise. + +.SH KEYWORDS +attributes, directory, file, name, stat diff --git a/vendor/x11iraf/obm/Tcl/doc/flush.n b/vendor/x11iraf/obm/Tcl/doc/flush.n new file mode 100644 index 00000000..bc668349 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/doc/flush.n @@ -0,0 +1,43 @@ +'\" +'\" Copyright (c) 1993 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 +'\" documentation for any purpose, provided that the above copyright +'\" notice and the following two paragraphs appear in all copies. +'\" +'\" 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 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. +'\" +'\" $Header: /user6/ouster/tcl/man/RCS/flush.n,v 1.1 93/05/03 17:09:40 ouster Exp $ SPRITE (Berkeley) +'\" +.so man.macros +.HS flush tcl +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +flush \- Flush buffered output for a file +.SH SYNOPSIS +\fBflush \fIfileId\fR +.BE + +.SH DESCRIPTION +.PP +Flushes any output that has been buffered for \fIfileId\fR. +\fIFileId\fR must have been the return +value from a previous call to \fBopen\fR, or it may be +\fBstdout\fR or \fBstderr\fR to access one of the standard I/O streams; +it must refer to a file that was opened for writing. +The command returns an empty string. + +.SH KEYWORDS +buffer, file, flush, output diff --git a/vendor/x11iraf/obm/Tcl/doc/for.n b/vendor/x11iraf/obm/Tcl/doc/for.n new file mode 100644 index 00000000..45915c6c --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/doc/for.n @@ -0,0 +1,57 @@ +'\" +'\" Copyright (c) 1993 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 +'\" documentation for any purpose, provided that the above copyright +'\" notice and the following two paragraphs appear in all copies. +'\" +'\" 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 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. +'\" +'\" $Header: /user6/ouster/tcl/man/RCS/for.n,v 1.1 93/05/03 17:09:41 ouster Exp $ SPRITE (Berkeley) +'\" +.so man.macros +.HS for tcl +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +for \- ``For'' loop +.SH SYNOPSIS +\fBfor \fIstart test next body\fR +.BE + +.SH DESCRIPTION +.PP +\fBFor\fR is a looping command, similar in structure to the C +\fBfor\fR statement. The \fIstart\fR, \fInext\fR, and +\fIbody\fR arguments must be Tcl command strings, and \fItest\fR +is an expression string. +The \fBfor\fR command first invokes the Tcl interpreter to +execute \fIstart\fR. Then it repeatedly evaluates \fItest\fR as +an expression; if the result is non-zero it invokes the Tcl +interpreter on \fIbody\fR, then invokes the Tcl interpreter on \fInext\fR, +then repeats the loop. The command terminates when \fItest\fR evaluates +to 0. If a \fBcontinue\fR command is invoked within \fIbody\fR then +any remaining commands in the current execution of \fIbody\fR are skipped; +processing continues by invoking the Tcl interpreter on \fInext\fR, then +evaluating \fItest\fR, and so on. If a \fBbreak\fR command is invoked +within \fIbody\fR +or \fInext\fR, +then the \fBfor\fR command will +return immediately. +The operation of \fBbreak\fR and \fBcontinue\fR are similar to the +corresponding statements in C. +\fBFor\fR returns an empty string. + +.SH KEYWORDS +for, iteration, looping diff --git a/vendor/x11iraf/obm/Tcl/doc/foreach.n b/vendor/x11iraf/obm/Tcl/doc/foreach.n new file mode 100644 index 00000000..63fe0063 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/doc/foreach.n @@ -0,0 +1,47 @@ +'\" +'\" Copyright (c) 1993 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 +'\" documentation for any purpose, provided that the above copyright +'\" notice and the following two paragraphs appear in all copies. +'\" +'\" 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 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. +'\" +'\" $Header: /user6/ouster/tcl/man/RCS/foreach.n,v 1.1 93/05/03 17:09:42 ouster Exp $ SPRITE (Berkeley) +'\" +.so man.macros +.HS foreach tcl +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +foreach \- Iterate over all elements in a list +.SH SYNOPSIS +\fBforeach \fIvarname list body\fR +.BE + +.SH DESCRIPTION +.PP +In this command \fIvarname\fR is the name of a variable, \fIlist\fR +is a list of values to assign to \fIvarname\fR, and \fIbody\fR is a +Tcl script. +For each element of \fIlist\fR (in order +from left to right), \fBforeach\fR assigns the contents of the +field to \fIvarname\fR as if the \fBlindex\fR command had been used +to extract the field, then calls the Tcl interpreter to execute +\fIbody\fR. The \fBbreak\fR and \fBcontinue\fR statements may be +invoked inside \fIbody\fR, with the same effect as in the \fBfor\fR +command. \fBForeach\fR returns an empty string. + +.SH KEYWORDS +foreach, iteration, list, looping diff --git a/vendor/x11iraf/obm/Tcl/doc/format.n b/vendor/x11iraf/obm/Tcl/doc/format.n new file mode 100644 index 00000000..69f66d2d --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/doc/format.n @@ -0,0 +1,233 @@ +'\" +'\" Copyright (c) 1993 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 +'\" documentation for any purpose, provided that the above copyright +'\" notice and the following two paragraphs appear in all copies. +'\" +'\" 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 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. +'\" +'\" $Header: /user6/ouster/tcl/man/RCS/format.n,v 1.4 93/08/05 13:56:19 ouster Exp $ SPRITE (Berkeley) +'\" +.so man.macros +.HS format tcl +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +format \- Format a string in the style of sprintf +.SH SYNOPSIS +\fBformat \fIformatString \fR?\fIarg arg ...\fR? +.BE + +.SH INTRODUCTION +.PP +This command generates a formatted string in the same way as the +ANSI C \fBsprintf\fR procedure (it uses \fBsprintf\fR in its +implementation). +\fIFormatString\fR indicates how to format the result, using +\fB%\fR conversion specifiers as in \fBsprintf\fR, and the additional +arguments, if any, provide values to be substituted into the result. +The return value from \fBformat\fR is the formatted string. + +.SH "DETAILS ON FORMATTING" +.PP +The command operates by scanning \fIformatString\fR from left to right. +Each character from the format string is appended to the result +string unless it is a percent sign. +If the character is a \fB%\fR then it is not copied to the result string. +Instead, the characters following the \fB%\fR character are treated as +a conversion specifier. +The conversion specifier controls the conversion of the next successive +\fIarg\fR to a particular format and the result is appended to +the result string in place of the conversion specifier. +If there are multiple conversion specifiers in the format string, +then each one controls the conversion of one additional \fIarg\fR. +The \fBformat\fR command must be given enough \fIarg\fRs to meet the needs +of all of the conversion specifiers in \fIformatString\fR. +.PP +Each conversion specifier may contain up to six different parts: +.VS +an XPG3 position specifier, +.VE +a set of flags, a minimum field width, a precision, a length modifier, +and a conversion character. +Any of these fields may be omitted except for the conversion character. +The fields that are present must appear in the order given above. +The paragraphs below discuss each of these fields in turn. +.PP +.VS +If the \fB%\fR is followed by a decimal number and a \fB$\fR, as in +``\fB%2$d\fR'', then the value to convert is not taken from the +next sequential argument. +Instead, it is taken from the argument indicated by the number, +where 1 corresponds to the first \fIarg\fR. +If the conversion specifier requires multiple arguments because +of \fB*\fR characters in the specifier then +successive arguments are used, starting with the argument +given by the number. +This follows the XPG3 conventions for positional specifiers. +If there are any positional specifiers in \fIformatString\fR +then all of the specifiers must be positional. +.VE +.PP +The second portion of a conversion specifier may contain any of the +following flag characters, in any order: +.TP 10 +\fB\-\fR +Specifies that the converted argument should be left-justified +in its field (numbers are normally right-justified with leading +spaces if needed). +.TP 10 +\fB+\fR +Specifies that a number should always be printed with a sign, +even if positive. +.TP 10 +\fIspace\fR +Specifies that a space should be added to the beginning of the +number if the first character isn't a sign. +.TP 10 +\fB0\fR +Specifies that the number should be padded on the left with +zeroes instead of spaces. +.TP 10 +\fB#\fR +Requests an alternate output form. For \fBo\fR and \fBO\fR +conversions it guarantees that the first digit is always \fB0\fR. +For \fBx\fR or \fBX\fR conversions, \fB0x\fR or \fB0X\fR (respectively) +will be added to the beginning of the result unless it is zero. +For all floating-point conversions (\fBe\fR, \fBE\fR, \fBf\fR, +\fBg\fR, and \fBG\fR) it guarantees that the result always +has a decimal point. +For \fBg\fR and \fBG\fR conversions it specifies that +trailing zeroes should not be removed. +.PP +The third portion of a conversion specifier is a number giving a +minimum field width for this conversion. +It is typically used to make columns line up in tabular printouts. +If the converted argument contains fewer characters than the +minimum field width then it will be padded so that it is as wide +as the minimum field width. +Padding normally occurs by adding extra spaces on the left of the +converted argument, but the \fB0\fR and \fB\-\fR flags +may be used to specify padding with zeroes on the left or with +spaces on the right, respectively. +If the minimum field width is specified as \fB*\fR rather than +a number, then the next argument to the \fBformat\fR command +determines the minimum field width; it must be a numeric string. +.PP +The fourth portion of a conversion specifier is a precision, +which consists of a period followed by a number. +The number is used in different ways for different conversions. +For \fBe\fR, \fBE\fR, and \fBf\fR conversions it specifies the number +of digits to appear to the right of the decimal point. +For \fBg\fR and \fBG\fR conversions it specifies the total number +of digits to appear, including those on both sides of the decimal +point (however, trailing zeroes after the decimal point will still +be omitted unless the \fB#\fR flag has been specified). +For integer conversions, it specifies a mimimum number of digits +to print (leading zeroes will be added if necessary). +For \fBs\fR conversions it specifies the maximum number of characters to be +printed; if the string is longer than this then the trailing characters will be dropped. +If the precision is specified with \fB*\fR rather than a number +then the next argument to the \fBformat\fR command determines the precision; +it must be a numeric string. +.PP +The fourth part of a conversion specifier is a length modifier, +which must be \fBh\fR or \fBl\fR. +If it is \fBh\fR it specifies that the numeric value should be +truncated to a 16-bit value before converting. +This option is rarely useful. +The \fBl\fR modifier is ignored. +.PP +The last thing in a conversion specifier is an alphabetic character +that determines what kind of conversion to perform. +The following conversion characters are currently supported: +.TP 10 +\fBd\fR +Convert integer to signed decimal string. +.TP 10 +\fBu\fR +Convert integer to unsigned decimal string. +.TP 10 +\fBi\fR +Convert integer to signed decimal string; the integer may either be +in decimal, in octal (with a leading \fB0\fR) or in hexadecimal +(with a leading \fB0x\fR). +.TP 10 +\fBo\fR +Convert integer to unsigned octal string. +.TP 10 +\fBx\fR or \fBX\fR +Convert integer to unsigned hexadecimal string, using digits +``0123456789abcdef'' for \fBx\fR and ``0123456789ABCDEF'' for \fBX\fR). +.TP 10 +\fBc\fR +Convert integer to the 8-bit character it represents. +.TP 10 +\fBs\fR +No conversion; just insert string. +.TP 10 +\fBf\fR +Convert floating-point number to signed decimal string of +the form \fIxx.yyy\fR, where the number of \fIy\fR's is determined by +the precision (default: 6). +If the precision is 0 then no decimal point is output. +.TP 10 +\fBe\fR or \fBe\fR +Convert floating-point number to scientific notation in the +form \fIx.yyy\fBe\(+-\fIzz\fR, where the number of \fIy\fR's is determined +by the precision (default: 6). +If the precision is 0 then no decimal point is output. +If the \fBE\fR form is used then \fBE\fR is +printed instead of \fBe\fR. +.TP 10 +\fBg\fR or \fBG\fR +If the exponent is less than \-4 or greater than or equal to the +precision, then convert floating-point number as for \fB%e\fR or +\fB%E\fR. +Otherwise convert as for \fB%f\fR. +Trailing zeroes and a trailing decimal point are omitted. +.TP 10 +\fB%\fR +No conversion: just insert \fB%\fR. +.LP +For the numerical conversions the argument being converted must +be an integer or floating-point string; format converts the argument +to binary and then converts it back to a string according to +the conversion specifier. + +.SH "DIFFERENCES FROM ANSI SPRINTF" +.PP +.VS +The behavior of the format command is the same as the +ANSI C \fBsprintf\fR procedure except for the following +differences: +.IP [1] +\fB%p\fR and \fB%n\fR specifiers are not currently supported. +.VE +.IP [2] +For \fB%c\fR conversions the argument must be a decimal string, +which will then be converted to the corresponding character value. +.IP [3] +.VS +The \fBl\fR modifier is ignored; integer values are always converted +as if there were no modifier present and real values are always +converted as if the \fBl\fR modifier were present (i.e. type +\fBdouble\fR is used for the internal representation). +If the \fBh\fR modifier is specified then integer values are truncated +to \fBshort\fR before conversion. +.VE + +.SH KEYWORDS +conversion specifier, format, sprintf, string, substitution diff --git a/vendor/x11iraf/obm/Tcl/doc/gets.n b/vendor/x11iraf/obm/Tcl/doc/gets.n new file mode 100644 index 00000000..da0bd3a0 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/doc/gets.n @@ -0,0 +1,61 @@ +'\" +'\" Copyright (c) 1993 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 +'\" documentation for any purpose, provided that the above copyright +'\" notice and the following two paragraphs appear in all copies. +'\" +'\" 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 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. +'\" +'\" $Header: /user6/ouster/tcl/man/RCS/gets.n,v 1.2 93/10/04 16:01:09 ouster Exp $ SPRITE (Berkeley) +'\" +.so man.macros +.HS gets tcl +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +gets \- Read a line from a file +.SH SYNOPSIS +\fBgets \fIfileId\fR ?\fIvarName\fR? +.BE + +.SH DESCRIPTION +.PP +This command reads the next line from the file given by \fIfileId\fR +and discards the terminating newline character. +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 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. +If the last character in the file is not a newline character then +\fBgets\fR behaves as if there were an additional newline character +at the end of the file. +\fIFileId\fR must be \fBstdin\fR or the return value from a previous +call to \fBopen\fR; it must refer to a file that was opened +for reading. +.VS +Any existing end-of-file or error condition on the file is cleared at +the beginning of the \fBgets\fR command. +.VE + +.SH KEYWORDS +file, line, read diff --git a/vendor/x11iraf/obm/Tcl/doc/glob.n b/vendor/x11iraf/obm/Tcl/doc/glob.n new file mode 100644 index 00000000..3b358e2d --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/doc/glob.n @@ -0,0 +1,92 @@ +'\" +'\" Copyright (c) 1993 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 +'\" documentation for any purpose, provided that the above copyright +'\" notice and the following two paragraphs appear in all copies. +'\" +'\" 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 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. +'\" +'\" $Header: /user6/ouster/tcl/man/RCS/glob.n,v 1.3 93/06/17 15:50:54 ouster Exp $ SPRITE (Berkeley) +'\" +.so man.macros +.HS glob tcl 7.0 +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +glob \- Return names of files that match patterns +.SH SYNOPSIS +\fBglob \fR?\fIswitches\fR? \fIpattern \fR?\fIpattern ...\fR? +.BE + +.SH DESCRIPTION +.PP +This command performs file name ``globbing'' in a fashion similar to +the csh shell. It returns a list of the files whose names match any +of the \fIpattern\fR arguments. +.LP +If the initial arguments to \fBglob\fR start with \fB\-\fR then +.VS +they are treated as switches. The following switches are +currently supported: +.TP 15 +\fB\-nocomplain\fR +Allows an empty list to be returned without error; without this +switch an error is returned if the result list would be empty. +.TP 15 +\fB\-\|\-\fR +Marks the end of switches. The argument following this one will +be treated as a \fIpattern\fR even if it starts with a \fB\-. +.VE +.PP +The \fIpattern\fR arguments may contain any of the following +special characters: +.TP 10 +\fB?\fR +Matches any single character. +.TP 10 +\fB*\fR +Matches any sequence of zero or more characters. +.TP 10 +\fB[\fIchars\fB]\fR +Matches any single character in \fIchars\fR. If \fIchars\fR +contains a sequence of the form \fIa\fB\-\fIb\fR then any +character between \fIa\fR and \fIb\fR (inclusive) will match. +.TP 10 +\fB\e\fIx\fR +Matches the character \fIx\fR. +.TP 10 +\fB{\fIa\fB,\fIb\fB,\fI...\fR} +Matches any of the strings \fIa\fR, \fIb\fR, etc. +.LP +As with csh, a ``.'' at the beginning of a file's name or just +after a ``/'' must be matched explicitly or with a {} construct. +In addition, all ``/'' characters must be matched explicitly. +.LP +If the first character in a \fIpattern\fR is ``~'' then it refers +to the home directory for the user whose name follows the ``~''. +If the ``~'' is followed immediately by ``/'' then the value of +the HOME environment variable is used. +.LP +The \fBglob\fR command differs from csh globbing in two ways. +First, it does not sort its result list (use the \fBlsort\fR +command if you want the list sorted). +.VS +Second, \fBglob\fR only returns the names of files that actually +exist; in csh no check for existence is made unless a pattern +contains a ?, *, or [] construct. +.VE + +.SH KEYWORDS +exist, file, glob, pattern diff --git a/vendor/x11iraf/obm/Tcl/doc/global.n b/vendor/x11iraf/obm/Tcl/doc/global.n new file mode 100644 index 00000000..4f7d7bd6 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/doc/global.n @@ -0,0 +1,43 @@ +'\" +'\" Copyright (c) 1993 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 +'\" documentation for any purpose, provided that the above copyright +'\" notice and the following two paragraphs appear in all copies. +'\" +'\" 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 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. +'\" +'\" $Header: /user6/ouster/tcl/man/RCS/global.n,v 1.1 93/05/03 17:09:46 ouster Exp $ SPRITE (Berkeley) +'\" +.so man.macros +.HS global tcl +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +global \- Access global variables +.SH SYNOPSIS +\fBglobal \fIvarname \fR?\fIvarname ...\fR? +.BE + +.SH DESCRIPTION +.PP +This command is ignored unless a Tcl procedure is being interpreted. +If so then it declares the given \fIvarname\fR's to be global variables +rather than local ones. For the duration of the current procedure +(and only while executing in the current procedure), any reference to +any of the \fIvarname\fRs will refer to the global variable by the same +name. + +.SH KEYWORDS +global, procedure, variable diff --git a/vendor/x11iraf/obm/Tcl/doc/history.n b/vendor/x11iraf/obm/Tcl/doc/history.n new file mode 100644 index 00000000..933b51b6 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/doc/history.n @@ -0,0 +1,181 @@ +'\" +'\" Copyright (c) 1993 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 +'\" documentation for any purpose, provided that the above copyright +'\" notice and the following two paragraphs appear in all copies. +'\" +'\" 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 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. +'\" +'\" $Header: /user6/ouster/tcl/man/RCS/history.n,v 1.1 93/05/03 17:09:47 ouster Exp $ SPRITE (Berkeley) +'\" +.so man.macros +.HS history tcl +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +history \- Manipulate the history list +.SH SYNOPSIS +\fBhistory \fR?\fIoption\fR? ?\fIarg arg ...\fR? +.BE + +.SH DESCRIPTION +.PP +The \fBhistory\fR command performs one of several operations related to +recently-executed commands recorded in a history list. Each of +these recorded commands is referred to as an ``event''. When +specifying an event to the \fBhistory\fR command, the following +forms may be used: +.IP [1] +A number: if positive, it refers to the event with +that number (all events are numbered starting at 1). If the number +is negative, it selects an event relative to the current event +(\fB\-1\fR refers to the previous event, \fB\-2\fR to the one before that, and +so on). +.IP [2] +A string: selects the most recent event that matches the string. +An event is considered to match the string either if the string is +the same as the first characters of the event, or if the string +matches the event in the sense of the \fBstring match\fR command. +.LP +The \fBhistory\fR command can take any of the following forms: +.TP +\fBhistory\fR +Same +as \fBhistory info\fR, described below. +.TP +\fBhistory add\fI command \fR?\fBexec\fR? +Adds the \fIcommand\fR argument to the history list as a new event. If +\fBexec\fR is specified (or abbreviated) then the command is also +executed and its result is returned. If \fBexec\fR isn't specified +then an empty string is returned as result. +.TP +\fBhistory change\fI newValue\fR ?\fIevent\fR? +Replaces the value recorded for an event with \fInewValue\fR. \fIEvent\fR +specifies the event to replace, and +defaults to the \fIcurrent\fR event (not event \fB\-1\fR). This command +is intended for use in commands that implement new forms of history +substitution and wish to replace the current event (which invokes the +substitution) with the command created through substitution. The return +value is an empty string. +.TP +\fBhistory event\fR ?\fIevent\fR? +Returns the value of the event given by \fIevent\fR. \fIEvent\fR +defaults to \fB\-1\fR. This command causes history revision to occur: +see below for details. +.TP +\fBhistory info \fR?\fIcount\fR? +Returns a formatted string (intended for humans to read) giving +the event number and contents for each of the events in the history +list except the current event. If \fIcount\fR is specified +then only the most recent \fIcount\fR events are returned. +.TP +\fBhistory keep \fIcount\fR +This command may be used to change the size of the history list to +\fIcount\fR events. Initially, 20 events are retained in the history +list. This command returns an empty string. +.TP +\fBhistory nextid\fR +Returns the number of the next event to be recorded +in the history list. It is useful for things like printing the +event number in command-line prompts. +.TP +\fBhistory redo \fR?\fIevent\fR? +Re-executes the command indicated by \fIevent\fR and return its result. +\fIEvent\fR defaults to \fB\-1\fR. This command results in history +revision: see below for details. +.TP +\fBhistory substitute \fIold new \fR?\fIevent\fR? +Retrieves the command given by \fIevent\fR +(\fB\-1\fR by default), replace any occurrences of \fIold\fR by +\fInew\fR in the command (only simple character equality is supported; +no wild cards), execute the resulting command, and return the result +of that execution. This command results in history +revision: see below for details. +.TP +\fBhistory words \fIselector\fR ?\fIevent\fR? +Retrieves from the command given by \fIevent\fR (\fB\-1\fR by default) +the words given by \fIselector\fR, and return those words in a string +separated by spaces. The \fBselector\fR argument has three forms. +If it is a single number then it selects the word given by that +number (\fB0\fR for the command name, \fB1\fR for its first argument, +and so on). If it consists of two numbers separated by a dash, +then it selects all the arguments between those two. Otherwise +\fBselector\fR is treated as a pattern; all words matching that +pattern (in the sense of \fBstring match\fR) are returned. In +the numeric forms \fB$\fR may be used +to select the last word of a command. +For example, suppose the most recent command in the history list is +.RS +.DS +\fBformat {%s is %d years old} Alice [expr $ageInMonths/12]\fR +.DE +Below are some history commands and the results they would produce: +.DS +.ta 4c +.fi +.UL Command " " +.UL Result +.nf + +\fBhistory words $ [expr $ageInMonths/12]\fR +\fBhistory words 1-2 {%s is %d years old} Alice\fR +\fBhistory words *a*o* {%s is %d years old} [expr $ageInMonths/12]\fR +.DE +\fBHistory words\fR results in history revision: see below for details. +.RE +.SH "HISTORY REVISION" +.PP +The history options \fBevent\fR, \fBredo\fR, \fBsubstitute\fR, +and \fBwords\fR result in ``history revision''. +When one of these options is invoked then the current event +is modified to eliminate the history command and replace it with +the result of the history command. +For example, suppose that the most recent command in the history +list is +.DS +\fBset a [expr $b+2]\fR +.DE +and suppose that the next command invoked is one of the ones on +the left side of the table below. The command actually recorded in +the history event will be the corresponding one on the right side +of the table. +.ne 1.5c +.DS +.ta 4c +.fi +.UL "Command Typed" " " +.UL "Command Recorded" +.nf + +\fBhistory redo set a [expr $b+2]\fR +\fBhistory s a b set b [expr $b+2]\fR +\fBset c [history w 2] set c [expr $b+2]\fR +.DE +History revision is needed because event specifiers like \fB\-1\fR +are only valid at a particular time: once more events have been +added to the history list a different event specifier would be +needed. +History revision occurs even when \fBhistory\fR is invoked +indirectly from the current event (e.g. a user types a command +that invokes a Tcl procedure that invokes \fBhistory\fR): the +top-level command whose execution eventually resulted in a +\fBhistory\fR command is replaced. +If you wish to invoke commands like \fBhistory words\fR without +history revision, you can use \fBhistory event\fR to save the +current history event and then use \fBhistory change\fR to +restore it later. + +.SH KEYWORDS +event, history, record, revision diff --git a/vendor/x11iraf/obm/Tcl/doc/if.n b/vendor/x11iraf/obm/Tcl/doc/if.n new file mode 100644 index 00000000..d15b90a5 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/doc/if.n @@ -0,0 +1,58 @@ +'\" +'\" Copyright (c) 1993 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 +'\" documentation for any purpose, provided that the above copyright +'\" notice and the following two paragraphs appear in all copies. +'\" +'\" 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 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. +'\" +'\" $Header: /user6/ouster/tcl/man/RCS/if.n,v 1.1 93/05/03 17:34:01 ouster Exp $ SPRITE (Berkeley) +'\" +.so man.macros +.HS if tcl +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +if \- Execute scripts conditionally +.SH SYNOPSIS +\fBif \fIexpr1 \fR?\fBthen\fR? \fIbody1 \fBelseif \fIexpr2 \fR?\fBthen\fR? \fIbody2\fR \fBelseif\fR ... \fR?\fBelse\fR? ?\fIbodyN\fR? +.BE + +.SH DESCRIPTION +.PP +The \fIif\fR command evaluates \fIexpr1\fR as an expression (in the +same way that \fBexpr\fR evaluates its argument). The value of the +expression must be a boolean +.VS +(a numeric value, where 0 is false and +anything is true, or a string value such as \fBtrue\fR or \fByes\fR +for true and \fBfalse\fR or \fBno\fR for false); +.VE +if it is true then \fIbody1\fR is executed by passing it to the +Tcl interpreter. +Otherwise \fIexpr2\fR is evaluated as an expression and if it is true +then \fBbody2\fR is executed, and so on. +If none of the expressions evaluates to true then \fIbodyN\fR is +executed. +The \fBthen\fR and \fBelse\fR arguments are optional +``noise words'' to make the command easier to read. +There may be any number of \fBelseif\fR clauses, including zero. +\fIBodyN\fR may also be omitted as long as \fBelse\fR is omitted too. +The return value from the command is the result of the body script +that was executed, or an empty string +if none of the expressions was non-zero and there was no \fIbodyN\fR. + +.SH KEYWORDS +boolean, conditional, else, false, if, true diff --git a/vendor/x11iraf/obm/Tcl/doc/incr.n b/vendor/x11iraf/obm/Tcl/doc/incr.n new file mode 100644 index 00000000..a5340105 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/doc/incr.n @@ -0,0 +1,44 @@ +'\" +'\" Copyright (c) 1993 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 +'\" documentation for any purpose, provided that the above copyright +'\" notice and the following two paragraphs appear in all copies. +'\" +'\" 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 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. +'\" +'\" $Header: /user6/ouster/tcl/man/RCS/incr.n,v 1.1 93/05/03 17:34:02 ouster Exp $ SPRITE (Berkeley) +'\" +.so man.macros +.HS incr tcl +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +incr \- Increment the value of a variable +.SH SYNOPSIS +\fBincr \fIvarName \fR?\fIincrement\fR? +.BE + +.SH DESCRIPTION +.PP +Increments the value stored in the variable whose name is \fIvarName\fR. +The value of the variable must be an integer. +If \fIincrement\fR is supplied then its value (which must be an +integer) is added to the value of variable \fIvarName\fR; otherwise +1 is added to \fIvarName\fR. +The new value is stored as a decimal string in variable \fIvarName\fR +and also returned as result. + +.SH KEYWORDS +add, increment, variable, value diff --git a/vendor/x11iraf/obm/Tcl/doc/info.n b/vendor/x11iraf/obm/Tcl/doc/info.n new file mode 100644 index 00000000..2806aa4a --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/doc/info.n @@ -0,0 +1,162 @@ +'\" +'\" Copyright (c) 1993 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 +'\" documentation for any purpose, provided that the above copyright +'\" notice and the following two paragraphs appear in all copies. +'\" +'\" 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 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. +'\" +'\" $Header: /user6/ouster/tcl/man/RCS/info.n,v 1.2 93/06/18 13:58:33 ouster Exp $ SPRITE (Berkeley) +'\" +.so man.macros +.HS info tcl 7.0 +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +info \- Return information about the state of the Tcl interpreter +.SH SYNOPSIS +\fBinfo \fIoption \fR?\fIarg arg ...\fR? +.BE + +.SH DESCRIPTION +.PP +This command provides information about various internals of the Tcl +interpreter. +The legal \fIoption\fR's (which may be abbreviated) are: +.TP +\fBinfo args \fIprocname\fR +Returns a list containing the names of the arguments to procedure +\fIprocname\fR, in order. \fIProcname\fR must be the name of a +Tcl command procedure. +.TP +\fBinfo body \fIprocname\fR +Returns the body of procedure \fIprocname\fR. \fIProcname\fR must be +the name of a Tcl command procedure. +.TP +\fBinfo cmdcount\fR +Returns a count of the total number of commands that have been invoked +in this interpreter. +.TP +\fBinfo commands \fR?\fIpattern\fR? +If \fIpattern\fR isn't specified, returns a list of names of all the +Tcl commands, including both the built-in commands written in C and +the command procedures defined using the \fBproc\fR command. +If \fIpattern\fR is specified, only those names matching \fIpattern\fR +are returned. Matching is determined using the same rules as for +\fBstring match\fR. +.TP +\fBinfo complete \fIcommand\fR +Returns 1 if \fIcommand\fR is a complete Tcl command in the sense of +having no unclosed quotes, braces, brackets or array element names, +If the command doesn't appear to be complete then 0 is returned. +This command is typically used in line-oriented input environments +to allow users to type in commands that span multiple lines; if the +command isn't complete, the script can delay evaluating it until additional +lines have been typed to complete the command. +.TP +\fBinfo default \fIprocname arg varname\fR +\fIProcname\fR must be the name of a Tcl command procedure and \fIarg\fR +must be the name of an argument to that procedure. If \fIarg\fR +doesn't have a default value then the command returns \fB0\fR. +Otherwise it returns \fB1\fR and places the default value of \fIarg\fR +into variable \fIvarname\fR. +.TP +\fBinfo exists \fIvarName\fR +Returns \fB1\fR if the variable named \fIvarName\fR exists in the +current context (either as a global or local variable), returns \fB0\fR +otherwise. +.TP +\fBinfo globals \fR?\fIpattern\fR? +If \fIpattern\fR isn't specified, returns a list of all the names +of currently-defined global variables. +If \fIpattern\fR is specified, only those names matching \fIpattern\fR +are returned. Matching is determined using the same rules as for +\fBstring match\fR. +.TP +\fBinfo level\fR ?\fInumber\fR? +If \fInumber\fR is not specified, this command returns a number +giving the stack level of the invoking procedure, or 0 if the +command is invoked at top-level. If \fInumber\fR is specified, +then the result is a list consisting of the name and arguments for the +procedure call at level \fInumber\fR on the stack. If \fInumber\fR +is positive then it selects a particular stack level (1 refers +to the top-most active procedure, 2 to the procedure it called, and +so on); otherwise it gives a level relative to the current level +(0 refers to the current procedure, -1 to its caller, and so on). +See the \fBuplevel\fR command for more information on what stack +levels mean. +.TP +\fBinfo library\fR +Returns the name of the library directory in which standard Tcl +scripts are stored. +The default value for the library is compiled into Tcl, but it +may be overridden by setting the TCL_LIBRARY environment variable. +If there is no TCL_LIBRARY variable and no compiled-in value then +and error is generated. +See the \fBlibrary\fR manual entry for details of the facilities +provided by the Tcl script library. +Normally each application will have its own application-specific +script library in addition to the Tcl script library; I suggest that +each application set a global variable with a name like +\fB$\fIapp\fB_library\fR (where \fIapp\fR is the application's name) +to hold the location of that application's library directory. +.TP +\fBinfo locals \fR?\fIpattern\fR? +If \fIpattern\fR isn't specified, returns a list of all the names +of currently-defined local variables, including arguments to the +current procedure, if any. +Variables defined with the \fBglobal\fR and \fBupvar\fR commands +will not be returned. +If \fIpattern\fR is specified, only those names matching \fIpattern\fR +are returned. Matching is determined using the same rules as for +\fBstring match\fR. +.TP +\fBinfo patchlevel\fR +.VS +Returns a decimal integer giving the current patch level for Tcl. +The patch level is incremented for each new release or patch, and +it uniquely identifies an official version of Tcl. +.VE +.TP +\fBinfo procs \fR?\fIpattern\fR? +If \fIpattern\fR isn't specified, returns a list of all the +names of Tcl command procedures. +If \fIpattern\fR is specified, only those names matching \fIpattern\fR +are returned. Matching is determined using the same rules as for +\fBstring match\fR. +.TP +\fBinfo script\fR +If a Tcl script file is currently being evaluated (i.e. there is a +call to \fBTcl_EvalFile\fR active or there is an active invocation +of the \fBsource\fR command), then this command returns the name +of the innermost file being processed. Otherwise the command returns an +empty string. +.TP +\fBinfo tclversion\fR +Returns the version number for this version of Tcl in the form \fIx.y\fR, +where changes to \fIx\fR represent major changes with probable +incompatibilities and changes to \fIy\fR represent small enhancements and +bug fixes that retain backward compatibility. +.TP +\fBinfo vars\fR ?\fIpattern\fR? +If \fIpattern\fR isn't specified, +returns a list of all the names of currently-visible variables, including +both locals and currently-visible globals. +If \fIpattern\fR is specified, only those names matching \fIpattern\fR +are returned. Matching is determined using the same rules as for +\fBstring match\fR. + +.SH KEYWORDS +command, information, interpreter, level, procedure, variable diff --git a/vendor/x11iraf/obm/Tcl/doc/join.n b/vendor/x11iraf/obm/Tcl/doc/join.n new file mode 100644 index 00000000..d98b0c77 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/doc/join.n @@ -0,0 +1,42 @@ +'\" +'\" Copyright (c) 1993 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 +'\" documentation for any purpose, provided that the above copyright +'\" notice and the following two paragraphs appear in all copies. +'\" +'\" 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 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. +'\" +'\" $Header: /user6/ouster/tcl/man/RCS/join.n,v 1.1 93/05/03 17:34:03 ouster Exp $ SPRITE (Berkeley) +'\" +.so man.macros +.HS join tcl +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +join \- Create a string by joining together list elements +.SH SYNOPSIS +\fBjoin \fIlist \fR?\fIjoinString\fR? +.BE + +.SH DESCRIPTION +.PP +The \fIlist\fR argument must be a valid Tcl list. +This command returns the string +formed by joining all of the elements of \fIlist\fR together with +\fIjoinString\fR separating each adjacent pair of elements. +The \fIjoinString\fR argument defaults to a space character. + +.SH KEYWORDS +element, join, list, separator diff --git a/vendor/x11iraf/obm/Tcl/doc/lappend.n b/vendor/x11iraf/obm/Tcl/doc/lappend.n new file mode 100644 index 00000000..02c6bcc3 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/doc/lappend.n @@ -0,0 +1,48 @@ +'\" +'\" Copyright (c) 1993 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 +'\" documentation for any purpose, provided that the above copyright +'\" notice and the following two paragraphs appear in all copies. +'\" +'\" 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 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. +'\" +'\" $Header: /user6/ouster/tcl/man/RCS/lappend.n,v 1.1 93/05/03 17:34:04 ouster Exp $ SPRITE (Berkeley) +'\" +.so man.macros +.HS lappend tcl +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +lappend \- Append list elements onto a variable +.SH SYNOPSIS +\fBlappend \fIvarName value \fR?\fIvalue value ...\fR? +.BE + +.SH DESCRIPTION +.PP +This command treats the variable given by \fIvarName\fR as a list +and appends each of the \fIvalue\fR arguments to that list as a separate +element, with spaces between elements. +If \fIvarName\fR doesn't exist, it is created as a list with elements +given by the \fIvalue\fR arguments. +\fBLappend\fR is similar to \fBappend\fR except that the \fIvalue\fRs +are appended as list elements rather than raw text. +This command provides a relatively efficient way to build up +large lists. For example, ``\fBlappend a $b\fR'' is much +more efficient than ``\fBset a [concat $a [list $b]]\fR'' when +\fB$a\fR is long. + +.SH KEYWORDS +append, element, list, variable diff --git a/vendor/x11iraf/obm/Tcl/doc/library.n b/vendor/x11iraf/obm/Tcl/doc/library.n new file mode 100644 index 00000000..619ac1f5 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/doc/library.n @@ -0,0 +1,239 @@ +'\" +'\" Copyright (c) 1991-1993 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 +'\" documentation for any purpose, provided that the above copyright +'\" notice and the following two paragraphs appear in all copies. +'\" +'\" 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 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. +'\" +'\" $Header: /user6/ouster/tcl/man/RCS/library.n,v 1.11 93/08/28 16:05:59 ouster Exp $ SPRITE (Berkeley) +' +.so man.macros +.de UL +\\$1\l'|0\(ul'\\$2 +.. +.HS library tcl +.BS +.SH NAME +library \- standard library of Tcl procedures +.SH SYNOPSIS +.nf +\fBauto_execok \fIcmd\fR +\fBauto_load \fIcmd\fR +\fBauto_mkindex \fIdir pattern pattern ...\fR +\fBauto_reset\fR +\fBparray \fIarrayName\fR +\fBunknown \fIcmd \fR?\fIarg arg ...\fR? +.fi +.BE + +.SH INTRODUCTION +.PP +Tcl includes a library of Tcl procedures for commonly-needed functions. +The procedures defined in the Tcl library are generic ones suitable +for use by many different applications. +The location of the Tcl library is returned by the \fBinfo library\fR +command. +In addition to the Tcl library, each application will normally have +its own library of support procedures as well; the location of this +library is normally given by the value of the \fB$\fIapp\fB_library\fR +global variable, where \fIapp\fR is the name of the application. +For example, the location of the Tk library is kept in the variable +\fB$tk_library\fR. +.PP +To access the procedures in the Tcl library, an application should +source the file \fBinit.tcl\fR in the library, for example with +the Tcl command +.DS +\fBsource [info library]/init.tcl +.DE +This will define the \fBunknown\fR procedure and arrange for the +other procedures to be loaded on-demand using the auto-load +mechanism defined below. + +.SH "COMMAND PROCEDURES" +.PP +The following procedures are provided in the Tcl library: +.TP +\fBauto_execok \fIcmd\fR +Determines whether there is an executable file by the name \fIcmd\fR. +This command examines the directories in the current search path +(given by the PATH enviornment variable) to see if there is an +executable file named \fIcmd\fR in any of those directories. +If so, it returns 1; if not it returns 0. \fBAuto_exec\fR +remembers information about previous searches in an array +named \fBauto_execs\fR; this avoids the path search in +future calls for the same \fIcmd\fR. The command \fBauto_reset\fR +may be used to force \fBauto_execok\fR to forget its cached +information. +.TP +\fBauto_load \fIcmd\fR +This command attempts to load the definition for a Tcl command named +\fIcmd\fR. +To do this, it searches an \fIauto-load path\fR, which is a list of +one or more directories. +The auto-load path is given by the global variable \fB$auto_path\fR +if it exists. +If there is no \fB$auto_path\fR variable, then the TCLLIBPATH environment +variable is used, if it exists. +Otherwise the auto-load path consists of just the Tcl library directory. +Within each directory in the auto-load path there must be a file +\fBtclIndex\fR that describes one +.VS +or more commands defined in that directory +and a script to evaluate to load each of the commands. +The \fBtclIndex\fR file should be generated with the +\fBauto_mkindex\fR command. +If \fIcmd\fR is found in an index file, then the appropriate +script is evaluated to create the command. +.VE +The \fBauto_load\fR command returns 1 if \fIcmd\fR was successfully +created. +The command returns 0 if there was no index entry for \fIcmd\fR +or if the script didn't actually define \fIcmd\fR (e.g. because +index information is out of date). +If an error occurs while processing the script, then that error +is returned. +\fBAuto_load\fR only reads the index information once and saves it +in the array \fBauto_index\fR; future calls to \fBauto_load\fR +check for \fIcmd\fR in the array rather than re-reading the index +files. +The cached index information may be deleted with the command +\fBauto_reset\fR. +This will force the next \fBauto_load\fR command to reload the +index database from disk. +.TP +\fBauto_mkindex \fIdir pattern pattern ...\fR +.VS +Generates an index suitable for use by \fBauto_load\fR. +The command searches \fIdir\fR for all files whose names match +any of the \fIpattern\fR arguments +.VE +(matching is done with the \fBglob\fR command), +generates an index of all the Tcl command +procedures defined in all the matching files, and stores the +index information in a file named \fBtclIndex\fR in \fIdir\fR. +For example, the command +.RS +.DS +\fBauto_mkindex foo *.tcl\fR +.DE +.LP +will read all the \fB.tcl\fR files in subdirectory \fBfoo\fR +and generate a new index file \fBfoo/tclIndex\fR. +.PP +\fBAuto_mkindex\fR parses the Tcl scripts in a relatively +unsophisticated way: if any line contains the word \fBproc\fR +as its first characters then it is assumed to be a procedure +definition and the next word of the line is taken as the +procedure's name. +Procedure definitions that don't appear in this way (e.g. they +have spaces before the \fBproc\fR) will not be indexed. +.RE +.TP +\fBauto_reset\fR +Destroys all the information cached by \fBauto_execok\fR and +\fBauto_load\fR. +This information will be re-read from disk the next time it is +needed. +\fBAuto_reset\fR also deletes any procedures listed in the auto-load +index, so that fresh copies of them will be loaded the next time +that they're used. +.TP +\fBparray \fIarrayName\fR +Prints on standard output the names and values of all the elements +in the array \fIarrayName\fR. +\fBArrayName\fR must be an array accessible to the caller of \fBparray\fR. +It may be either local or global. +.TP +\fBunknown \fIcmd \fR?\fIarg arg ...\fR? +This procedure is invoked automatically by the Tcl interpreter +whenever the name of a command doesn't exist. +The \fBunknown\fR procedure receives as its arguments the +name and arguments of the missing command. +.VS +\fBUnknown\fR first calls \fBauto_load\fR to load the command. +.VE +If this succeeds, then it executes the original command with its +original arguments. +If the auto-load fails then \fBunknown\fR calls \fBauto_execok\fR +to see if there is an executable file by the name \fIcmd\fR. +If so, it invokes the Tcl \fBexec\fR command +with \fIcmd\fR and all the \fIargs\fR as arguments. +If \fIcmd\fR can't be auto-executed, \fBunknown\fR checks to +see if the command was invoked at top-level and outside of any +script. If so, then \fBunknown\fR takes takes two additional steps. +First, it sees if \fIcmd\fR has one of the following three forms: +\fB!!\fR, \fB!\fIevent\fR, or \fB^\fIold\fB^\fInew\fR?\fB^\fR?. +If so, then \fBunknown\fR carries out history substitution +in the same way that \fBcsh\fR would for these constructs. +Second, and last, \fBunknown\fR checks to see if \fIcmd\fR is +a unique abbreviation for an existing Tcl command. +If so, it expands the command name and executes the command with +the original arguments. +If none of the above efforts has been able to execute +the command, \fBunknown\fR generates an error return. +If the global variable \fBauto_noload\fR is defined, then the auto-load +step is skipped. +If the global variable \fBauto_noexec\fR is defined then the +auto-exec step is skipped. +Under normal circumstances the return value from \fBunknown\fR +is the return value from the command that was eventually +executed. + +.SH "VARIABLES" +.PP +The following global variables are defined or used by the procedures in +the Tcl library: +.TP +\fBauto_execs\fR +Used by \fBauto_execok\fR to record information about whether +particular commands exist as executable files. +.TP +\fBauto_index\fR +Used by \fBauto_load\fR to save the index information read from +disk. +.TP +\fBauto_noexec\fR +If set to any value, then \fBunknown\fR will not attempt to auto-exec +any commands. +.TP +\fBauto_noload\fR +If set to any value, then \fBunknown\fR will not attempt to auto-load +any commands. +.TP +\fBauto_path\fR +If set, then it must contain a valid Tcl list giving directories to +search during auto-load operations. +.TP +\fBenv(TCL_LIBRARY)\fR +If set, then it specifies the location of the directory containing +library scripts (the value of this variable will be returned by +the command \fBinfo library\fR). If this variable isn't set then +a default value is used. +.TP +\fBenv(TCLLIBPATH)\fR +If set, then it must contain a valid Tcl list giving directories to +search during auto-load operations. +This variable is only used if \fBauto_path\fR is not defined. +.TP +\fBunknown_active\fR +This variable is set by \fBunknown\fR to indicate that it is active. +It is used to detect errors where \fBunknown\fR recurses on itself +infinitely. +The variable is unset before \fBunknown\fR returns. + +.SH KEYWORDS +auto-exec, auto-load, library, unknown diff --git a/vendor/x11iraf/obm/Tcl/doc/lindex.n b/vendor/x11iraf/obm/Tcl/doc/lindex.n new file mode 100644 index 00000000..60bd0a81 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/doc/lindex.n @@ -0,0 +1,46 @@ +'\" +'\" Copyright (c) 1993 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 +'\" documentation for any purpose, provided that the above copyright +'\" notice and the following two paragraphs appear in all copies. +'\" +'\" 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 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. +'\" +'\" $Header: /user6/ouster/tcl/man/RCS/lindex.n,v 1.1 93/05/03 17:34:05 ouster Exp $ SPRITE (Berkeley) +'\" +.so man.macros +.HS lindex tcl +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +lindex \- Retrieve an element from a list +.SH SYNOPSIS +\fBlindex \fIlist index\fR +.BE + +.SH DESCRIPTION +.PP +This command treats \fIlist\fR as a Tcl list and returns the +\fIindex\fR'th element from it (0 refers to the first element of the list). +In extracting the element, \fIlindex\fR observes the same rules +concerning braces and quotes and backslashes as the Tcl command +interpreter; however, variable +substitution and command substitution do not occur. +If \fIindex\fR is negative or greater than or equal to the number +of elements in \fIvalue\fR, then an empty +string is returned. + +.SH KEYWORDS +element, index, list diff --git a/vendor/x11iraf/obm/Tcl/doc/linsert.n b/vendor/x11iraf/obm/Tcl/doc/linsert.n new file mode 100644 index 00000000..1cb7e5e7 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/doc/linsert.n @@ -0,0 +1,45 @@ +'\" +'\" Copyright (c) 1993 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 +'\" documentation for any purpose, provided that the above copyright +'\" notice and the following two paragraphs appear in all copies. +'\" +'\" 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 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. +'\" +'\" $Header: /user6/ouster/tcl/man/RCS/linsert.n,v 1.1 93/05/03 17:34:05 ouster Exp $ SPRITE (Berkeley) +'\" +.so man.macros +.HS linsert tcl +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +linsert \- Insert elements into a list +.SH SYNOPSIS +\fBlinsert \fIlist index element \fR?\fIelement element ...\fR? +.BE + +.SH DESCRIPTION +.PP +This command produces a new list from \fIlist\fR by inserting all +of the \fIelement\fR arguments just before the \fIindex\fRth +element of \fIlist\fR. Each \fIelement\fR argument will become +a separate element of the new list. If \fIindex\fR is less than +or equal to zero, then the new elements are inserted at the +beginning of the list. If \fIindex\fR is greater than or equal +to the number of elements in the list, then the new elements are +appended to the list. + +.SH KEYWORDS +element, insert, list diff --git a/vendor/x11iraf/obm/Tcl/doc/list.n b/vendor/x11iraf/obm/Tcl/doc/list.n new file mode 100644 index 00000000..40992062 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/doc/list.n @@ -0,0 +1,62 @@ +'\" +'\" Copyright (c) 1993 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 +'\" documentation for any purpose, provided that the above copyright +'\" notice and the following two paragraphs appear in all copies. +'\" +'\" 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 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. +'\" +'\" $Header: /user6/ouster/tcl/man/RCS/list.n,v 1.2 93/10/28 16:19:11 ouster Exp $ SPRITE (Berkeley) +'\" +.so man.macros +.HS list tcl +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +list \- Create a list +.SH SYNOPSIS +.VS +\fBlist \fR?\fIarg arg ...\fR? +.VE +.BE + +.SH DESCRIPTION +.PP +This command returns a list comprised of all the \fIarg\fRs, +.VS +or an empty string if no \fIarg\fRs are specified. +.VE +Braces and backslashes get added as necessary, so that the \fBindex\fR command +may be used on the result to re-extract the original arguments, and also +so that \fBeval\fR may be used to execute the resulting list, with +\fIarg1\fR comprising the command's name and the other \fIarg\fRs comprising +its arguments. \fBList\fR produces slightly different results than +\fBconcat\fR: \fBconcat\fR removes one level of grouping before forming +the list, while \fBlist\fR works directly from the original arguments. +For example, the command +.DS +\fBlist a b {c d e} {f {g h}} +.DE +will return +.DS +\fBa b {c d e} {f {g h}} +.DE +while \fBconcat\fR with the same arguments will return +.DS +\fBa b c d e f {g h}\fR +.DE + +.SH KEYWORDS +element, list diff --git a/vendor/x11iraf/obm/Tcl/doc/llength.n b/vendor/x11iraf/obm/Tcl/doc/llength.n new file mode 100644 index 00000000..aecba66a --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/doc/llength.n @@ -0,0 +1,39 @@ +'\" +'\" Copyright (c) 1993 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 +'\" documentation for any purpose, provided that the above copyright +'\" notice and the following two paragraphs appear in all copies. +'\" +'\" 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 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. +'\" +'\" $Header: /user6/ouster/tcl/man/RCS/llength.n,v 1.1 93/05/03 17:34:07 ouster Exp $ SPRITE (Berkeley) +'\" +.so man.macros +.HS llength tcl +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +llength \- Count the number of elements in a list +.SH SYNOPSIS +\fBllength \fIlist\fR +.BE + +.SH DESCRIPTION +.PP +Treats \fIlist\fR as a list and returns a decimal string giving +the number of elements in it. + +.SH KEYWORDS +element, list, length diff --git a/vendor/x11iraf/obm/Tcl/doc/lrange.n b/vendor/x11iraf/obm/Tcl/doc/lrange.n new file mode 100644 index 00000000..b963906d --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/doc/lrange.n @@ -0,0 +1,51 @@ +'\" +'\" Copyright (c) 1993 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 +'\" documentation for any purpose, provided that the above copyright +'\" notice and the following two paragraphs appear in all copies. +'\" +'\" 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 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. +'\" +'\" $Header: /user6/ouster/tcl/man/RCS/lrange.n,v 1.1 93/05/03 17:34:07 ouster Exp $ SPRITE (Berkeley) +'\" +.so man.macros +.HS lrange tcl +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +lrange \- Return one or more adjacent elements from a list +.SH SYNOPSIS +\fBlrange \fIlist first last +.BE + +.SH DESCRIPTION +.PP +\fIList\fR must be a valid Tcl list. This command will +return a new list consisting of elements +\fIfirst\fR through \fIlast\fR, inclusive. +\fILast\fR may be \fBend\fR (or any +abbreviation of it) to refer to the last element of the list. +If \fIfirst\fR is less than zero, it is treated as if it were zero. +If \fIlast\fR is greater than or equal to the number of elements +in the list, then it is treated as if it were \fBend\fR. +If \fIfirst\fR is greater than \fIlast\fR then an empty string +is returned. +Note: ``\fBlrange \fIlist first first\fR'' does not always produce the +same result as ``\fBlindex \fIlist first\fR'' (although it often does +for simple fields that aren't enclosed in braces); it does, however, +produce exactly the same results as ``\fBlist [lindex \fIlist first\fB]\fR'' + +.SH KEYWORDS +element, list, range, sublist diff --git a/vendor/x11iraf/obm/Tcl/doc/lreplace.n b/vendor/x11iraf/obm/Tcl/doc/lreplace.n new file mode 100644 index 00000000..c7d96f58 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/doc/lreplace.n @@ -0,0 +1,55 @@ +'\" +'\" Copyright (c) 1993 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 +'\" documentation for any purpose, provided that the above copyright +'\" notice and the following two paragraphs appear in all copies. +'\" +'\" 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 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. +'\" +'\" $Header: /user6/ouster/tcl/man/RCS/lreplace.n,v 1.1 93/05/03 17:34:08 ouster Exp $ SPRITE (Berkeley) +'\" +.so man.macros +.HS lreplace tcl +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +lreplace \- Replace elements in a list with new elements +.SH SYNOPSIS +\fBlreplace \fIlist first last \fR?\fIelement element ...\fR? +.BE + +.SH DESCRIPTION +.PP +\fBLreplace\fR returns a new list formed by replacing one or more elements of +\fIlist\fR with the \fIelement\fR arguments. +\fIFirst\fR gives the index in \fIlist\fR of the first element +to be replaced. +If \fIfirst\fR is less than zero then it refers to the first +element of \fIlist\fR; the element indicated by \fIfirst\fR +must exist in the list. +\fILast\fR gives the index in \fIlist\fR of the last element +to be replaced; it must be greater than or equal to \fIfirst\fR. +\fILast\fR may be \fBend\fR (or any abbreviation of it) to indicate +that all elements between \fIfirst\fR and the end of the list should +be replaced. +The \fIelement\fR arguments specify zero or more new arguments to +be added to the list in place of those that were deleted. +Each \fIelement\fR argument will become a separate element of +the list. +If no \fIelement\fR arguments are specified, then the elements +between \fIfirst\fR and \fIlast\fR are simply deleted. + +.SH KEYWORDS +element, list, replace diff --git a/vendor/x11iraf/obm/Tcl/doc/lsearch.n b/vendor/x11iraf/obm/Tcl/doc/lsearch.n new file mode 100644 index 00000000..af87eb7f --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/doc/lsearch.n @@ -0,0 +1,60 @@ +'\" +'\" Copyright (c) 1993 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 +'\" documentation for any purpose, provided that the above copyright +'\" notice and the following two paragraphs appear in all copies. +'\" +'\" 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 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. +'\" +'\" $Header: /user6/ouster/tcl/man/RCS/lsearch.n,v 1.2 93/05/07 14:27:07 ouster Exp $ SPRITE (Berkeley) +'\" +.so man.macros +.HS lsearch tcl 7.0 +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +lsearch \- See if a list contains a particular element +.SH SYNOPSIS +\fBlsearch \fR?\fImode\fR? \fIlist pattern\fR +.BE + +.SH DESCRIPTION +.PP +This command searches the elements of \fIlist\fR to see if one +of them matches \fIpattern\fR. +If so, the command returns the index of the first matching +element. +If not, the command returns \fB\-1\fR. +.VS +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: +.TP +\fB\-exact\fR +The list element must contain exactly the same string as \fIpattern\fR. +.TP +\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. +.TP +\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. +.PP +If \fImode\fR is omitted then it defaults to \fB\-glob\fR. +.VE + +.SH KEYWORDS +list, match, pattern, regular expression, search, string diff --git a/vendor/x11iraf/obm/Tcl/doc/lsort.n b/vendor/x11iraf/obm/Tcl/doc/lsort.n new file mode 100644 index 00000000..a9985d14 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/doc/lsort.n @@ -0,0 +1,72 @@ +'\" +'\" Copyright (c) 1993 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 +'\" documentation for any purpose, provided that the above copyright +'\" notice and the following two paragraphs appear in all copies. +'\" +'\" 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 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. +'\" +'\" $Header: /user6/ouster/tcl/man/RCS/lsort.n,v 1.2 93/05/07 16:48:45 ouster Exp $ SPRITE (Berkeley) +'\" +.so man.macros +.HS lsort tcl 7.0 +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +lsort \- Sort the elements of a list +.SH SYNOPSIS +\fBlsort \fR?\fIswitches\fR? \fIlist\fR +.BE + +.SH DESCRIPTION +.PP +This command sorts the elements of \fIlist\fR, returning a new +list in sorted order. By default ASCII sorting is used with +the result returned in increasing order. +.VS +However, any of the +following switches may be specified before \fIlist\fR to +control the sorting process (unique abbreviations are accepted): +.TP 20 +\fB\-ascii\fR +Use string comparison with ASCII collation order. This is +the default. +.TP 20 +\fB\-integer\fR +Convert list elements to integers and use integer comparison. +.TP 20 +\fB\-real\fR +Convert list elements to floating-point values and use floating +comparison. +.TP 20 +\fB\-command\0\fIcommand\fR +Use \fIcommand\fR as a comparison command. +To compare two elements, evaluate a Tcl script consisting of +\fIcommand\fR with the two elements appended as additional +arguments. The script should return an integer less than, +equal to, or greater than zero if the first element is to +be considered less than, equal to, or greater than the second, +respectively. +.TP 20 +\fB\-increasing\fR +Sort the list in increasing order (``smallest'' items first). +This is the default. +.TP 20 +\fB\-decreasing\fR +Sort the list in decreasing order (``largest'' items first). +.VE + +.SH KEYWORDS +element, list, order, sort diff --git a/vendor/x11iraf/obm/Tcl/doc/man.macros b/vendor/x11iraf/obm/Tcl/doc/man.macros new file mode 100644 index 00000000..f45afa8e --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/doc/man.macros @@ -0,0 +1,182 @@ +.\" The definitions below are for supplemental macros used in Tcl/Tk +.\" manual entries. +.\" +.\" .HS name section [date [version]] +.\" Replacement for .TH in other man pages. See below for valid +.\" section names. +.\" +.\" .AP type name in/out [indent] +.\" Start paragraph describing an argument to a library procedure. +.\" type is type of argument (int, etc.), in/out is either "in", "out", +.\" or "in/out" to describe whether procedure reads or modifies arg, +.\" and indent is equivalent to second arg of .IP (shouldn't ever be +.\" needed; use .AS below instead) +.\" +.\" .AS [type [name]] +.\" Give maximum sizes of arguments for setting tab stops. Type and +.\" name are examples of largest possible arguments that will be passed +.\" to .AP later. If args are omitted, default tab stops are used. +.\" +.\" .BS +.\" Start box enclosure. From here until next .BE, everything will be +.\" enclosed in one large box. +.\" +.\" .BE +.\" End of box enclosure. +.\" +.\" .VS +.\" Begin vertical sidebar, for use in marking newly-changed parts +.\" of man pages. +.\" +.\" .VE +.\" End of vertical sidebar. +.\" +.\" .DS +.\" Begin an indented unfilled display. +.\" +.\" .DE +.\" End of indented unfilled display. +.\" +'\" # Heading for Tcl/Tk man pages +.de HS +.ds ^3 \\0 +.if !"\\$3"" .ds ^3 \\$3 +.if '\\$2'cmds' .TH \\$1 1 \\*(^3 \\$4 +.if '\\$2'lib' .TH \\$1 3 \\*(^3 \\$4 +.if '\\$2'tcl' .TH \\$1 n \\*(^3 Tcl "Tcl Built-In Commands" +.if '\\$2'tk' .TH \\$1 n \\*(^3 Tk "Tk Commands" +.if '\\$2'tclc' .TH \\$1 3 \\*(^3 Tcl "Tcl Library Procedures" +.if '\\$2'tkc' .TH \\$1 3 \\*(^3 Tk "Tk Library Procedures" +.if '\\$2'tclcmds' .TH \\$1 1 \\*(^3 Tk "Tcl Applications" +.if '\\$2'tkcmds' .TH \\$1 1 \\*(^3 Tk "Tk Applications" +.if t .wh -1.3i ^B +.nr ^l \\n(.l +.ad b +.. +'\" # Start an argument description +.de AP +.ie !"\\$4"" .TP \\$4 +.el \{\ +. ie !"\\$2"" .TP \\n()Cu +. el .TP 15 +.\} +.ie !"\\$3"" \{\ +.ta \\n()Au \\n()Bu +\&\\$1 \\fI\\$2\\fP (\\$3) +.\".b +.\} +.el \{\ +.br +.ie !"\\$2"" \{\ +\&\\$1 \\fI\\$2\\fP +.\} +.el \{\ +\&\\fI\\$1\\fP +.\} +.\} +.. +'\" # define tabbing values for .AP +.de AS +.nr )A 10n +.if !"\\$1"" .nr )A \\w'\\$1'u+3n +.nr )B \\n()Au+15n +.\" +.if !"\\$2"" .nr )B \\w'\\$2'u+\\n()Au+3n +.nr )C \\n()Bu+\\w'(in/out)'u+2n +.. +'\" # BS - start boxed text +'\" # ^y = starting y location +'\" # ^b = 1 +.de BS +.br +.mk ^y +.nr ^b 1u +.if n .nf +.if n .ti 0 +.if n \l'\\n(.lu\(ul' +.if n .fi +.. +'\" # BE - end boxed text (draw box now) +.de BE +.nf +.ti 0 +.mk ^t +.ie n \l'\\n(^lu\(ul' +.el \{\ +.\" Draw four-sided box normally, but don't draw top of +.\" box if the box started on an earlier page. +.ie !\\n(^b-1 \{\ +\h'-1.5n'\L'|\\n(^yu-1v'\l'\\n(^lu+3n\(ul'\L'\\n(^tu+1v-\\n(^yu'\l'|0u-1.5n\(ul' +.\} +.el \}\ +\h'-1.5n'\L'|\\n(^yu-1v'\h'\\n(^lu+3n'\L'\\n(^tu+1v-\\n(^yu'\l'|0u-1.5n\(ul' +.\} +.\} +.fi +.br +.nr ^b 0 +.. +'\" # VS - start vertical sidebar +'\" # ^Y = starting y location +'\" # ^v = 1 (for troff; for nroff this doesn't matter) +.de VS +.mk ^Y +.ie n 'mc \s12\(br\s0 +.el .nr ^v 1u +.. +'\" # VE - end of vertical sidebar +.de VE +.ie n 'mc +.el \{\ +.ev 2 +.nf +.ti 0 +.mk ^t +\h'|\\n(^lu+3n'\L'|\\n(^Yu-1v\(bv'\v'\\n(^tu+1v-\\n(^Yu'\h'-|\\n(^lu+3n' +.sp -1 +.fi +.ev +.\} +.nr ^v 0 +.. +'\" # Special macro to handle page bottom: finish off current +'\" # box/sidebar if in box/sidebar mode, then invoked standard +'\" # page bottom macro. +.de ^B +.ev 2 +'ti 0 +'nf +.mk ^t +.if \\n(^b \{\ +.\" Draw three-sided box if this is the box's first page, +.\" draw two sides but no top otherwise. +.ie !\\n(^b-1 \h'-1.5n'\L'|\\n(^yu-1v'\l'\\n(^lu+3n\(ul'\L'\\n(^tu+1v-\\n(^yu'\h'|0u'\c +.el \h'-1.5n'\L'|\\n(^yu-1v'\h'\\n(^lu+3n'\L'\\n(^tu+1v-\\n(^yu'\h'|0u'\c +.\} +.if \\n(^v \{\ +.nr ^x \\n(^tu+1v-\\n(^Yu +\kx\h'-\\nxu'\h'|\\n(^lu+3n'\ky\L'-\\n(^xu'\v'\\n(^xu'\h'|0u'\c +.\} +.bp +'fi +.ev +.if \\n(^b \{\ +.mk ^y +.nr ^b 2 +.\} +.if \\n(^v \{\ +.mk ^Y +.\} +.. +'\" # DS - begin display +.de DS +.RS +.nf +.sp +.. +'\" # DE - end display +.de DE +.fi +.RE +.sp .5 +.. diff --git a/vendor/x11iraf/obm/Tcl/doc/open.n b/vendor/x11iraf/obm/Tcl/doc/open.n new file mode 100644 index 00000000..8bd39ae1 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/doc/open.n @@ -0,0 +1,138 @@ +'\" +'\" Copyright (c) 1993 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 +'\" documentation for any purpose, provided that the above copyright +'\" notice and the following two paragraphs appear in all copies. +'\" +'\" 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 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. +'\" +'\" $Header: /user6/ouster/tcl/man/RCS/open.n,v 1.1 93/05/10 17:10:32 ouster Exp $ SPRITE (Berkeley) +'\" +.so man.macros +.HS open tcl 7.0 +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +open \- Open a file +.SH SYNOPSIS +.VS +\fBopen \fIfileName\fR ?\fIaccess\fR? ?\fIpermissions\fR? +.VE +.BE + +.SH DESCRIPTION +.PP +This command opens a file and returns an identifier +that may be used in future invocations +of commands like \fBread\fR, \fBputs\fR, and \fBclose\fR. +\fIFileName\fR gives the name of the file to open; if it starts with +a tilde then tilde substitution is performed as described for +\fBTcl_TildeSubst\fR. +If the first character of \fIfileName\fR is ``|'' then the +remaining characters of \fIfileName\fR are treated as a command +pipeline to invoke, in the same style as for \fBexec\fR. +In this case, the identifier returned by \fBopen\fR may be used +to write to the command's input pipe or read from its output pipe. +.PP +The \fIaccess\fR argument indicates the way in which the file +(or command pipeline) is to be accessed. +.VS +It may take two forms, either a string in the form that would be +passed to the \fBfopen\fR library procedure or a list of POSIX +access flags. +It defaults to ``\fBr\fR''. +In the first form \fIaccess\fR may have any of the following values: +.VE +.TP 15 +\fBr\fR +Open the file for reading only; the file must already exist. +.TP 15 +\fBr+\fR +Open the file for both reading and writing; the file must +already exist. +.TP 15 +\fBw\fR +Open the file for writing only. Truncate it if it exists. If it doesn't +exist, create a new file. +.TP 15 +\fBw+\fR +Open the file for reading and writing. Truncate it if it exists. +If it doesn't exist, create a new file. +.TP 15 +\fBa\fR +Open the file for writing only. The file must already exist, and the file +is positioned so that new data is appended to the file. +.TP 15 +\fBa+\fR +Open the file for reading and writing. If the file doesn't exist, +create a new empty file. +Set the initial access position to the end of the file. +.PP +In the second form, \fIaccess\fR consists of a list of any of the +.VS +following flags, all of which have the standard POSIX meanings. +One of the flags must be either \fBRDONLY\fR, \fBWRONLY\fR or \fBRDWR\fR. +.TP 15 +\fBRDONLY\fR +Open the file for reading only. +.TP 15 +\fBWRONLY\fR +Open the file for writing only. +.TP 15 +\fBRDWR\fR +Open the file for both reading and writing. +.TP 15 +\fBAPPEND\fR +Set the file pointer to the end of the file prior to each write. +.TP 15 +\fBCREAT\fR +Create the file if it doesn't already exist (without this flag it +is an error for the file not to exist). +.TP 15 +\fBEXCL\fR +If \fBCREAT\fR is specified also, an error is returned if the +file already exists. +.TP 15 +\fBNOCTTY\fR +If the file is a terminal device, this flag prevents the file from +becoming the controlling terminal of the process. +.TP 15 +\fBNONBLOCK\fR +Prevents the process from blocking while opening the file. +For details refer to your system documentation on the \fBopen\fR system +call's \fBO_NONBLOCK\fR flag. +.TP 15 +\fBTRUNC\fR +If the file exists it is truncated to zero length. +.PP +If a new file is created as part of opening it, \fIpermissions\fR +(an integer) is used to set the permissions for the new file in +conjunction with the process's file mode creation mask. +\fIPermissions\fR defaults to 0666. +.VE +.PP +If a file is opened for both reading and writing then \fBseek\fR +must be invoked between a read and a write, or vice versa (this +restriction does not apply to command pipelines opened with \fBopen\fR). +When \fIfileName\fR specifies a command pipeline and a write-only access +is used, then standard output from the pipeline is directed to the +current standard output unless overridden by the command. +When \fIfileName\fR specifies a command pipeline and a read-only access +is used, then standard input from the pipeline is taken from the +current standard input unless overridden by the command. + +.SH KEYWORDS +access mode, append, controlling terminal, create, file, +non-blocking, open, permissions, pipeline, process diff --git a/vendor/x11iraf/obm/Tcl/doc/pid.n b/vendor/x11iraf/obm/Tcl/doc/pid.n new file mode 100644 index 00000000..ff671c5d --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/doc/pid.n @@ -0,0 +1,47 @@ +'\" +'\" Copyright (c) 1993 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 +'\" documentation for any purpose, provided that the above copyright +'\" notice and the following two paragraphs appear in all copies. +'\" +'\" 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 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. +'\" +'\" $Header: /user6/ouster/tcl/man/RCS/pid.n,v 1.1 93/05/15 16:19:40 ouster Exp $ SPRITE (Berkeley) +'\" +.so man.macros +.HS pid tcl 7.0 +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +pid \- Retrieve process id(s) +.SH SYNOPSIS +\fBpid \fR?\fIfileId\fR? +.BE + +.SH DESCRIPTION +.PP +If the \fIfileId\fR argument is given then it should normally +refer to a process pipeline created with the \fBopen\fR command. +In this case the \fBpid\fR command will return a list whose elements +are the process identifiers of all the processes in the pipeline, +in order. +The list will be empty if \fIfileId\fR refers to an open file +that isn't a process pipeline. +If no \fIfileId\fR argument is given then \fBpid\fR returns the process +identifier of the current process. +All process identifiers are returned as decimal strings. + +.SH KEYWORDS +file, pipeline, process identifier diff --git a/vendor/x11iraf/obm/Tcl/doc/proc.n b/vendor/x11iraf/obm/Tcl/doc/proc.n new file mode 100644 index 00000000..14061205 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/doc/proc.n @@ -0,0 +1,80 @@ +'\" +'\" Copyright (c) 1993 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 +'\" documentation for any purpose, provided that the above copyright +'\" notice and the following two paragraphs appear in all copies. +'\" +'\" 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 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. +'\" +'\" $Header: /user6/ouster/tcl/man/RCS/proc.n,v 1.1 93/05/10 17:10:18 ouster Exp $ SPRITE (Berkeley) +'\" +.so man.macros +.HS proc tcl +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +proc \- Create a Tcl procedure +.SH SYNOPSIS +\fBproc \fIname args body\fR +.BE + +.SH DESCRIPTION +.PP +The \fBproc\fR command creates a new Tcl procedure named +\fIname\fR, replacing +any existing command or procedure there may have been by that name. +Whenever the new command is invoked, the contents of \fIbody\fR will +be executed by the Tcl interpreter. +\fIArgs\fR specifies the formal arguments to the +procedure. It consists of a list, possibly empty, each of whose +elements specifies +one argument. Each argument specifier is also a list with either +one or two fields. If there is only a single field in the specifier +then it is the name of the argument; if there are two fields, then +the first is the argument name and the second is its default value. +.PP +When \fIname\fR is invoked a local variable +will be created for each of the formal arguments to the procedure; its +value will be the value of corresponding argument in the invoking command +or the argument's default value. +Arguments with default values need not be +specified in a procedure invocation. However, there must be enough +actual arguments for all the +formal arguments that don't have defaults, and there must not be any extra +actual arguments. There is one special case to permit procedures with +variable numbers of arguments. If the last formal argument has the name +\fBargs\fR, then a call to the procedure may contain more actual arguments +than the procedure has formals. In this case, all of the actual arguments +starting at the one that would be assigned to \fBargs\fR are combined into +a list (as if the \fBlist\fR command had been used); this combined value +is assigned to the local variable \fBargs\fR. +.PP +When \fIbody\fR is being executed, variable names normally refer to +local variables, which are created automatically when referenced and +deleted when the procedure returns. One local variable is automatically +created for each of the procedure's arguments. +Global variables can only be accessed by invoking +the \fBglobal\fR command or the \fBupvar\fR command. +.PP +The \fBproc\fR command returns an empty string. When a procedure is +invoked, the procedure's return value is the value specified in a +\fBreturn\fR command. If the procedure doesn't execute an explicit +\fBreturn\fR, then its return value is the value of the last command +executed in the procedure's body. +If an error occurs while executing the procedure +body, then the procedure-as-a-whole will return that same error. + +.SH KEYWORDS +argument, procedure diff --git a/vendor/x11iraf/obm/Tcl/doc/puts.n b/vendor/x11iraf/obm/Tcl/doc/puts.n new file mode 100644 index 00000000..294d4172 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/doc/puts.n @@ -0,0 +1,50 @@ +'\" +'\" Copyright (c) 1993 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 +'\" documentation for any purpose, provided that the above copyright +'\" notice and the following two paragraphs appear in all copies. +'\" +'\" 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 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. +'\" +'\" $Header: /user6/ouster/tcl/man/RCS/puts.n,v 1.1 93/05/10 17:10:19 ouster Exp $ SPRITE (Berkeley) +'\" +.so man.macros +.HS puts tcl +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +puts \- Write to a file +.SH SYNOPSIS +\fBputs \fR?\fB\-nonewline\fR? ?\fIfileId\fR? \fIstring\fR +.BE + +.SH DESCRIPTION +.PP +Writes the characters given by \fIstring\fR to the file given +by \fIfileId\fR. +\fIFileId\fR must have been the return +value from a previous call to \fBopen\fR, or it may be +\fBstdout\fR or \fBstderr\fR to refer to one of the standard I/O +channels; it must refer to a file that was opened for +writing. +If no \fIfileId\fR is specified then it defaults to \fBstdout\fR. +\fBPuts\fR normally outputs a newline character after \fIstring\fR, +but this feature may be suppressed by specifying the \fB\-nonewline\fR +switch. +Output to files is buffered internally by Tcl; the \fBflush\fR +command may be used to force buffered characters to be output. + +.SH KEYWORDS +file, newline, output, write diff --git a/vendor/x11iraf/obm/Tcl/doc/pwd.n b/vendor/x11iraf/obm/Tcl/doc/pwd.n new file mode 100644 index 00000000..b4eb5575 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/doc/pwd.n @@ -0,0 +1,38 @@ +'\" +'\" Copyright (c) 1993 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 +'\" documentation for any purpose, provided that the above copyright +'\" notice and the following two paragraphs appear in all copies. +'\" +'\" 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 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. +'\" +'\" $Header: /user6/ouster/tcl/man/RCS/pwd.n,v 1.1 93/05/10 17:10:19 ouster Exp $ SPRITE (Berkeley) +'\" +.so man.macros +.HS pwd tcl +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +pwd \- Return the current working directory +.SH SYNOPSIS +\fBpwd\fR +.BE + +.SH DESCRIPTION +.PP +Returns the path name of the current working directory. + +.SH KEYWORDS +working directory diff --git a/vendor/x11iraf/obm/Tcl/doc/read.n b/vendor/x11iraf/obm/Tcl/doc/read.n new file mode 100644 index 00000000..3507e0e2 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/doc/read.n @@ -0,0 +1,54 @@ +'\" +'\" Copyright (c) 1993 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 +'\" documentation for any purpose, provided that the above copyright +'\" notice and the following two paragraphs appear in all copies. +'\" +'\" 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 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. +'\" +'\" $Header: /user6/ouster/tcl/man/RCS/read.n,v 1.2 93/10/04 16:01:04 ouster Exp $ SPRITE (Berkeley) +'\" +.so man.macros +.HS read tcl +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +read \- Read from a file +.SH SYNOPSIS +\fBread \fR?\fB\-nonewline\fR? \fIfileId\fR +.br +\fBread \fIfileId numBytes\fR +.BE + +.SH DESCRIPTION +.PP +In the first form, all of the remaining bytes are read from the file +given by \fIfileId\fR; they are returned as the result of the command. +If the \fB\-nonewline\fR switch is specified then the last +character of the file is discarded if it is a newline. +In the second form, the extra argument specifies how many bytes to read; +exactly this 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. +\fIFileId\fR must be \fBstdin\fR or the return +value from a previous call to \fBopen\fR; it must +refer to a file that was opened for reading. +.VS +Any existing end-of-file or error condition on the file is cleared at +the beginning of the \fBread\fR command. +.VE + +.SH KEYWORDS +file, read diff --git a/vendor/x11iraf/obm/Tcl/doc/regexp.n b/vendor/x11iraf/obm/Tcl/doc/regexp.n new file mode 100644 index 00000000..b3a5d71f --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/doc/regexp.n @@ -0,0 +1,160 @@ +'\" +'\" Copyright (c) 1993 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 +'\" documentation for any purpose, provided that the above copyright +'\" notice and the following two paragraphs appear in all copies. +'\" +'\" 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 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. +'\" +'\" $Header: /user6/ouster/tcl/man/RCS/regexp.n,v 1.4 93/08/03 16:37:28 ouster Exp $ SPRITE (Berkeley) +'\" +.so man.macros +.HS regexp tcl +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +regexp \- Match a regular expression against a string +.SH SYNOPSIS +\fBregexp \fR?\fIswitches\fR? \fIexp string \fR?\fImatchVar\fR? ?\fIsubMatchVar subMatchVar ...\fR? +.BE + +.SH DESCRIPTION +.PP +Determines whether the regular expression \fIexp\fR matches part or +all of \fIstring\fR and returns 1 if it does, 0 if it doesn't. +.LP +If additional arguments are specified after \fIstring\fR then they +are treated as the names of variables in which to return +information about which part(s) of \fIstring\fR matched \fIexp\fR. +\fIMatchVar\fR will be set to the range of \fIstring\fR that +matched all of \fIexp\fR. The first \fIsubMatchVar\fR will contain +the characters in \fIstring\fR that matched the leftmost parenthesized +subexpression within \fIexp\fR, the next \fIsubMatchVar\fR will +contain the characters that matched the next parenthesized +subexpression to the right in \fIexp\fR, and so on. +.LP +If the initial arguments to \fBregexp\fR start with \fB\-\fR then +.VS +they are treated as switches. The following switches are +currently supported: +.TP 10 +\fB\-nocase\fR +Causes upper-case characters in \fIstring\fR to be treated as +lower case during the matching process. +.TP 10 +\fB\-indices\fR +Changes what is stored in the \fIsubMatchVar\fRs. +Instead of storing the matching characters from \fBstring\fR, +each variable +will contain a list of two decimal strings giving the indices +in \fIstring\fR of the first and last characters in the matching +range of characters. +.TP 10 +\fB\-\|\-\fR +Marks the end of switches. The argument following this one will +be treated as \fIexp\fR even if it starts with a \fB\-. +.VE +.LP +If there are more \fIsubMatchVar\fR's than parenthesized +subexpressions within \fIexp\fR, or if a particular subexpression +in \fIexp\fR doesn't match the string (e.g. because it was in a +portion of the expression that wasn't matched), then the corresponding +\fIsubMatchVar\fR will be set to ``\fB\-1 \-1\fR'' if \fB\-indices\fR +has been specified or to an empty string otherwise. + +.SH "REGULAR EXPRESSIONS" +.PP +Regular expressions are implemented using Henry Spencer's package +(thanks, Henry!), +and much of the description of regular expressions below is copied verbatim +from his manual entry. +.PP +A regular expression is zero or more \fIbranches\fR, separated by ``|''. +It matches anything that matches one of the branches. +.PP +A branch is zero or more \fIpieces\fR, concatenated. +It matches a match for the first, followed by a match for the second, etc. +.PP +A piece is an \fIatom\fR possibly followed by ``*'', ``+'', or ``?''. +An atom followed by ``*'' matches a sequence of 0 or more matches of the atom. +An atom followed by ``+'' matches a sequence of 1 or more matches of the atom. +An atom followed by ``?'' matches a match of the atom, or the null string. +.PP +An atom is a regular expression in parentheses (matching a match for the +regular expression), a \fIrange\fR (see below), ``.'' +(matching any single character), ``^'' (matching the null string at the +beginning of the input string), ``$'' (matching the null string at the +end of the input string), a ``\e'' followed by a single character (matching +that character), or a single character with no other significance +(matching that character). +.PP +A \fIrange\fR is a sequence of characters enclosed in ``[]''. +It normally matches any single character from the sequence. +If the sequence begins with ``^'', +it matches any single character \fInot\fR from the rest of the sequence. +If two characters in the sequence are separated by ``\-'', this is shorthand +for the full list of ASCII characters between them +(e.g. ``[0-9]'' matches any decimal digit). +To include a literal ``]'' in the sequence, make it the first character +(following a possible ``^''). +To include a literal ``\-'', make it the first or last character. + +.SH "CHOOSING AMONG ALTERNATIVE MATCHES" +.PP +In general there may be more than one way to match a regular expression +to an input string. For example, consider the command +.DS +\fBregexp (a*)b* aabaaabb x y +.DE +Considering only the rules given so far, \fBx\fR and \fBy\fR could +end up with the values \fBaabb\fR and \fBaa\fR, \fBaaab\fR and \fBaaa\fR, +\fBab\fR and \fBa\fR, or any of several other combinations. +To resolve this potential ambiguity \fBregexp\fR chooses among +alternatives using the rule ``first then longest''. +In other words, it consders the possible matches in order working +from left to right across the input string and the pattern, and it +attempts to match longer pieces of the input string before shorter +ones. More specifically, the following rules apply in decreasing +order of priority: +.IP [1] +If a regular expression could match two different parts of an input string +then it will match the one that begins earliest. +.IP [2] +If a regular expression contains \fB|\fR operators then the leftmost +matching sub-expression is chosen. +.IP [3] +In \fB*\fR, \fB+\fR, and \fB?\fR constructs, longer matches are chosen +in preference to shorter ones. +.IP [4] +In sequences of expression components the components are considered +from left to right. +.LP +In the example from above, \fB(a*)b*\fR matches \fBaab\fR: the \fB(a*)\fR +portion of the pattern is matched first and it consumes the leading +\fBaa\fR; then the \fBb*\fR portion of the pattern consumes the +next \fBb\fR. Or, consider the following example: +.DS +\fBregexp (ab|a)(b*)c abc x y z +.DE +After this command \fBx\fR will be \fBabc\fR, \fBy\fR will be +\fBab\fR, and \fBz\fR will be an empty string. +Rule 4 specifies that \fB(ab|a)\fR gets first shot at the input +string and Rule 2 specifies that the \fBab\fR sub-expression +is checked before the \fBa\fR sub-expression. +Thus the \fBb\fR has already been claimed before the \fB(b*)\fR +component is checked and \fB(b*)\fR must match an empty string. + +.SH KEYWORDS +match, regular expression, string diff --git a/vendor/x11iraf/obm/Tcl/doc/regsub.n b/vendor/x11iraf/obm/Tcl/doc/regsub.n new file mode 100644 index 00000000..0a3e704c --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/doc/regsub.n @@ -0,0 +1,88 @@ +'\" +'\" Copyright (c) 1993 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 +'\" documentation for any purpose, provided that the above copyright +'\" notice and the following two paragraphs appear in all copies. +'\" +'\" 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 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. +'\" +'\" $Header: /user6/ouster/tcl/man/RCS/regsub.n,v 1.2 93/06/17 13:31:43 ouster Exp $ SPRITE (Berkeley) +'\" +.so man.macros +.HS regsub tcl +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +regsub \- Perform substitutions based on regular expression pattern matching +.SH SYNOPSIS +\fBregsub \fR?\fIswitches\fR? \fIexp string subSpec varName\fR +.BE + +.SH DESCRIPTION +.PP +This command matches the regular expression \fIexp\fR against +\fIstring\fR, +.VS +and it copies \fIstring\fR to the variable whose name is +given by \fIvarName\fR. +The command returns 1 if there is a match and 0 if there isn't. +If there is a match, then while copying \fIstring\fR to \fIvarName\fR +the portion of \fIstring\fR that +.VE +matched \fIexp\fR is replaced with \fIsubSpec\fR. +If \fIsubSpec\fR contains a ``&'' or ``\e0'', then it is replaced +in the substitution with the portion of \fIstring\fR that +matched \fIexp\fR. +If \fIsubSpec\fR contains a ``\e\fIn\fR'', where \fIn\fR is a digit +between 1 and 9, then it is replaced in the substitution with +the portion of \fIstring\fR that matched the \fIn\fR-th +parenthesized subexpression of \fIexp\fR. +Additional backslashes may be used in \fIsubSpec\fR to prevent special +interpretation of ``&'' or ``\e0'' or ``\e\fIn\fR'' or +backslash. +The use of backslashes in \fIsubSpec\fR tends to interact badly +with the Tcl parser's use of backslashes, so it's generally +safest to enclose \fIsubSpec\fR in braces if it includes +backslashes. +.LP +If the initial arguments to \fBregexp\fR start with \fB\-\fR then +.VS +they are treated as switches. The following switches are +currently supported: +.TP 10 +\fB\-all\fR +All ranges in \fIstring\fR that match \fIexp\fR are found and +substitution is performed for each of these ranges. +Without this switch only the first +matching range is found and substituted. +If \fB\-all\fR is specified, then ``&'' and ``\e\fIn\fR'' +sequences are handled for each substitution using the information +from the corresponding match. +.TP 10 +\fB\-nocase\fR +Upper-case characters in \fIstring\fR will be converted to lower-case +before matching against \fIexp\fR; however, substitutions specified +by \fIsubSpec\fR use the original unconverted form of \fIstring\fR. +.TP 10 +\fB\-\|\-\fR +Marks the end of switches. The argument following this one will +be treated as \fIexp\fR even if it starts with a \fB\-. +.VE +.PP +See the manual entry for \fBregexp\fR for details on the interpretation +of regular expressions. + +.SH KEYWORDS +match, pattern, regular expression, substitute diff --git a/vendor/x11iraf/obm/Tcl/doc/rename.n b/vendor/x11iraf/obm/Tcl/doc/rename.n new file mode 100644 index 00000000..490f52b0 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/doc/rename.n @@ -0,0 +1,41 @@ +'\" +'\" Copyright (c) 1993 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 +'\" documentation for any purpose, provided that the above copyright +'\" notice and the following two paragraphs appear in all copies. +'\" +'\" 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 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. +'\" +'\" $Header: /user6/ouster/tcl/man/RCS/rename.n,v 1.1 93/06/07 16:48:22 ouster Exp $ SPRITE (Berkeley) +'\" +.so man.macros +.HS rename tcl +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +rename \- Rename or delete a command +.SH SYNOPSIS +\fBrename \fIoldName newName\fR +.BE + +.SH DESCRIPTION +.PP +Rename the command that used to be called \fIoldName\fR so that it +is now called \fInewName\fR. If \fInewName\fR is an empty string +then \fIoldName\fR is deleted. The \fBrename\fR command +returns an empty string as result. + +.SH KEYWORDS +command, delete, rename diff --git a/vendor/x11iraf/obm/Tcl/doc/return.n b/vendor/x11iraf/obm/Tcl/doc/return.n new file mode 100644 index 00000000..cb80b61d --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/doc/return.n @@ -0,0 +1,104 @@ +'\" +'\" Copyright (c) 1993 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 +'\" documentation for any purpose, provided that the above copyright +'\" notice and the following two paragraphs appear in all copies. +'\" +'\" 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 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. +'\" +'\" $Header: /user6/ouster/tcl/man/RCS/return.n,v 1.8 93/08/03 16:15:41 ouster Exp $ SPRITE (Berkeley) +'\" +.so man.macros +.HS return tcl 7.0 +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +return \- Return from a procedure +.SH SYNOPSIS +\fBreturn \fR?\fB\-code \fIcode\fR? ?\fB\-errorinfo \fIinfo\fR? ?\fB\-errorcode\fI code\fR? ?\fIstring\fR? +.BE + +.SH DESCRIPTION +.PP +Return immediately from the current procedure +(or top-level command or \fBsource\fR command), +with \fIstring\fR as the return value. If \fIstring\fR is not specified then +an empty string will be returned as result. + +.SH "EXCEPTIONAL RETURNS" +.PP +In the usual case where the \fB\-code\fR option isn't +.VS +specified the procedure will return normally (its completion +code will be TCL_OK). +However, the \fB\-code\fR option may be used to generate an +exceptional return from the procedure. +\fICode\fR may have any of the following values: +.TP 10 +\fBok\fR +Normal return: same as if the option is omitted. +.TP 10 +\fBerror\fR +Error return: same as if the \fBerror\fR command were used to +terminate the procedure, except for handling of \fBerrorInfo\fR +and \fBerrorCode\fR variables (see below). +.TP 10 +\fBreturn\fR +The current procedure will return with a completion code of +TCL_RETURN, so that the procedure that invoked it will return +also. +.TP 10 +\fBbreak\fR +The current procedure will return with a completion code of +TCL_BREAK, which will terminate the innermost nested loop in +the code that invoked the current procedure. +.TP 10 +\fBcontinue\fR +The current procedure will return with a completion code of +TCL_CONTINUE, which will terminate the current iteration of +the innermost nested loop in the code that invoked the current +procedure. +.TP 10 +\fIvalue\fR +\fIValue\fR must be an integer; it will be returned as the +completion code for the current procedure. +.LP +The \fB\-code\fR option is rarely used. +It is provided so that procedures that implement +new control structures can reflect exceptional conditions back to +their callers. +.PP +Two additional options, \fB\-errorinfo\fR and \fB\-errorcode\fR, +may be used to provide additional information during error +returns. +These options are ignored unless \fIcode\fR is \fBerror\fR. +.PP +The \fB\-errorinfo\fR option specifies an initial stack +trace for the \fBerrorInfo\fR variable; if it is not specified then +the stack trace left in \fBerrorInfo\fR will include the call to +the procedure and higher levels on the stack but it will not include +any information about the context of the error within the procedure. +Typically the \fIinfo\fR value is supplied from the value left +in \fBerrorInfo\fR after a \fBcatch\fR command trapped an error within +the procedure. +.PP +If the \fB\-errorcode\fR option is specified then \fIcode\fR provides +a value for the \fBerrorCode\fR variable. +If the option is not specified then \fBerrorCode\fR will +default to \fBNONE\fR. +.VE + +.SH KEYWORDS +break, continue, error, procedure, return diff --git a/vendor/x11iraf/obm/Tcl/doc/scan.n b/vendor/x11iraf/obm/Tcl/doc/scan.n new file mode 100644 index 00000000..b2b15209 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/doc/scan.n @@ -0,0 +1,149 @@ +'\" +'\" Copyright (c) 1993 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 +'\" documentation for any purpose, provided that the above copyright +'\" notice and the following two paragraphs appear in all copies. +'\" +'\" 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 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. +'\" +'\" $Header: /user6/ouster/tcl/man/RCS/scan.n,v 1.3 93/08/04 17:18:42 ouster Exp $ SPRITE (Berkeley) +'\" +.so man.macros +.HS scan tcl +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +scan \- Parse string using conversion specifiers in the style of sscanf +.SH SYNOPSIS +\fBscan \fIstring format varName \fR?\fIvarName ...\fR? +.BE + +.SH INTRODUCTION +.PP +This command parses fields from an input string in the same fashion +as the ANSI C \fBsscanf\fR procedure and returns a count of the number +of fields sucessfully parsed. +\fIString\fR gives the input to be parsed and \fIformat\fR indicates +how to parse it, using \fB%\fR conversion specifiers as in \fBsscanf\fR. +Each \fIvarName\fR gives the name of a variable; when a field is +scanned from \fIstring\fR the result is converted back into a string +and assigned to the corresponding variable. + +.SH "DETAILS ON SCANNING" +.PP +\fBScan\fR operates by scanning \fIstring\fR and \fIformatString\fR together. +If the next character in \fIformatString\fR is a blank or tab then it +is ignored. +Otherwise, if it isn't a \fB%\fR character then it +must match the next non-white-space character of \fIstring\fR. +When a \fB%\fR is encountered in \fIformatString\fR, it indicates +the start of a conversion specifier. +A conversion specifier contains three fields after the \fB%\fR: +a \fB*\fR, which indicates that the converted value is to be discarded +instead of assigned to a variable; a number indicating a maximum field +width; and a conversion character. +All of these fields are optional except for the conversion character. +.PP +When \fBscan\fR finds a conversion specifier in \fIformatString\fR, it +first skips any white-space characters in \fIstring\fR. +Then it converts the next input characters according to the +conversion specifier and stores the result in the variable given +by the next argument to \fBscan\fR. +The following conversion characters are supported: +.TP 10 +\fBd\fR +The input field must be a decimal integer. +It is read in and the value is stored in the variable as a decimal string. +.TP 10 +\fBo\fR +The input field must be an octal integer. It is read in and the +value is stored in the variable as a decimal string. +.TP 10 +\fBx\fR +The input field must be a hexadecimal integer. It is read in +and the value is stored in the variable as a decimal string. +.TP 10 +\fBc\fR +A single character is read in and its binary value is stored in +the variable as a decimal string. +Initial white space is not skipped in this case, so the input +field may be a white-space character. +This conversion is different from the ANSI standard in that the +input field always consists of a single character and no field +width may be specified. +.TP 10 +\fBs\fR +The input field consists of all the characters up to the next +white-space character; the characters are copied to the variable. +.TP 10 +\fBe\fR or \fBf\fR or \fBg\fR +The input field must be a floating-point number consisting +of an optional sign, a string of decimal digits possibly con +taining a decimal point, and an optional exponent consisting +of an \fBe\fR or \fBE\fR followed by an optional sign and a string of +decimal digits. +It is read in and stored in the variable as a floating-point string. +.TP 10 +\fB[\fIchars\fB] +The input field consists of any number of characters in +\fIchars\fR. +The matching string is stored in the variable. +If the first character between the brackets is a \fB]\fR then +it is treated as part of \fIchars\fR rather than the closing +bracket for the set. +.TP 10 +\fB[^\fIchars\fB] +The input field consists of any number of characters not in +\fIchars\fR. +The matching string is stored in the variable. +If the character immediately following the \fB^\fR is a \fB]\fR then it is +treated as part of the set rather than the closing bracket for +the set. +.LP +The number of characters read from the input for a conversion is the +largest number that makes sense for that particular conversion (e.g. +as many decimal digits as possible for \fB%d\fR, as +many octal digits as possible for \fB%o\fR, and so on). +The input field for a given conversion terminates either when a +white-space character is encountered or when the maximum field +width has been reached, whichever comes first. +If a \fB*\fR is present in the conversion specifier +then no variable is assigned and the next scan argument is not consumed. + +.SH "DIFFERENCES FROM ANSI SSCANF" +.PP +The behavior of the \fBscan\fR command is the same as the behavior of +the ANSI C \fBsscanf\fR procedure except for the following differences: +.IP [1] +.VS +\fB%p\fR and \fB%n\fR conversion specifiers are not currently +supported. +.VE +.IP [2] +For \fB%c\fR conversions a single character value is +converted to a decimal string, which is then assigned to the +corresponding \fIvarName\fR; +no field width may be specified for this conversion. +.IP [3] +.VS +The \fBl\fR, \fBh\fR, and \fBL\fR modifiers are ignored; integer +values are always converted as if there were no modifier present +and real values are always converted as if the \fBl\fR modifier +were present (i.e. type \fBdouble\fR is used for the internal +representation). +.VE + +.SH KEYWORDS +conversion specifier, parse, scan diff --git a/vendor/x11iraf/obm/Tcl/doc/seek.n b/vendor/x11iraf/obm/Tcl/doc/seek.n new file mode 100644 index 00000000..832d8a65 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/doc/seek.n @@ -0,0 +1,64 @@ +'\" +'\" Copyright (c) 1993 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 +'\" documentation for any purpose, provided that the above copyright +'\" notice and the following two paragraphs appear in all copies. +'\" +'\" 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 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. +'\" +'\" $Header: /user6/ouster/tcl/man/RCS/seek.n,v 1.1 93/06/07 16:48:27 ouster Exp $ SPRITE (Berkeley) +'\" +.so man.macros +.HS seek tcl +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +seek \- Change the access position for an open file +.SH SYNOPSIS +\fBseek \fIfileId offset \fR?\fIorigin\fR? +.BE + +.SH DESCRIPTION +.PP +Change the current access position for \fIfileId\fR. +\fIFileId\fR must have been the return +value from a previous call to \fBopen\fR, or it may be \fBstdin\fR, +\fBstdout\fR, or \fBstderr\fR to refer to one of the standard I/O +channels. +The \fIoffset\fR and \fIorigin\fR arguments specify the position at +which the next read or write will occur for \fIfileId\fR. +\fIOffset\fR must be an integer (which may be negative) and \fIorigin\fR +must be one of the following: +.TP +\fBstart\fR +The new access position will be \fIoffset\fR bytes from the start +of the file. +.TP +\fBcurrent\fR +The new access position will be \fIoffset\fR bytes from the current +access position; a negative \fIoffset\fR moves the access position +backwards in the file. +.TP +\fBend\fR +The new access position will be \fIoffset\fR bytes from the end of +the file. A negative \fIoffset\fR places the access position before +the end-of-file, and a positive \fIoffset\fR places the access position +after the end-of-file. +.LP +The \fIorigin\fR argument defaults to \fBstart\fR. +This command returns an empty string. + +.SH KEYWORDS +access position, file, seek diff --git a/vendor/x11iraf/obm/Tcl/doc/set.n b/vendor/x11iraf/obm/Tcl/doc/set.n new file mode 100644 index 00000000..1fda124e --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/doc/set.n @@ -0,0 +1,51 @@ +'\" +'\" Copyright (c) 1993 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 +'\" documentation for any purpose, provided that the above copyright +'\" notice and the following two paragraphs appear in all copies. +'\" +'\" 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 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. +'\" +'\" $Header: /user6/ouster/tcl/man/RCS/set.n,v 1.1 93/06/07 16:48:27 ouster Exp $ SPRITE (Berkeley) +'\" +.so man.macros +.HS set tcl +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +set \- Read and write variables +.SH SYNOPSIS +\fBset \fIvarName \fR?\fIvalue\fR? +.BE + +.SH DESCRIPTION +.PP +Returns the value of variable \fIvarName\fR. +If \fIvalue\fR is specified, then set +the value of \fIvarName\fR to \fIvalue\fR, creating a new variable +if one doesn't already exist, and return its value. +If \fIvarName\fR contains an open parenthesis and ends with a +close parenthesis, then it refers to an array element: the characters +before the first open parenthesis are the name of the array, and the characters +between the parentheses are the index within the array. +Otherwise \fIvarName\fR refers to a scalar variable. +If no procedure is active, then \fIvarName\fR refers to a global +variable. +If a procedure is active, then \fIvarName\fR refers to a parameter +or local variable of the procedure unless the \fIglobal\fR command +has been invoked to declare \fIvarName\fR to be global. + +.SH KEYWORDS +read, write, variable diff --git a/vendor/x11iraf/obm/Tcl/doc/source.n b/vendor/x11iraf/obm/Tcl/doc/source.n new file mode 100644 index 00000000..124d8049 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/doc/source.n @@ -0,0 +1,47 @@ +'\" +'\" Copyright (c) 1993 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 +'\" documentation for any purpose, provided that the above copyright +'\" notice and the following two paragraphs appear in all copies. +'\" +'\" 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 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. +'\" +'\" $Header: /user6/ouster/tcl/man/RCS/source.n,v 1.1 93/06/07 16:48:28 ouster Exp $ SPRITE (Berkeley) +'\" +.so man.macros +.HS source tcl +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +source \- Evaluate a file as a Tcl script +.SH SYNOPSIS +\fBsource \fIfileName\fR +.BE + +.SH DESCRIPTION +.PP +Read file \fIfileName\fR and pass the contents to the Tcl interpreter +as a script to evaluate in the normal fashion. The return +value from \fBsource\fR is the return value of the last command executed +from the file. If an error occurs in evaluating the contents of the +file then the \fBsource\fR command will return that error. +If a \fBreturn\fR command is invoked from within the file then the remainder of +the file will be skipped and the \fBsource\fR command will return +normally with the result from the \fBreturn\fR command. +If \fIfileName\fR starts with a tilde, then it is tilde-substituted +as described in the \fBTcl_TildeSubst\fR manual entry. + +.SH KEYWORDS +file, script diff --git a/vendor/x11iraf/obm/Tcl/doc/split.n b/vendor/x11iraf/obm/Tcl/doc/split.n new file mode 100644 index 00000000..cd1f1dc3 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/doc/split.n @@ -0,0 +1,57 @@ +'\" +'\" Copyright (c) 1993 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 +'\" documentation for any purpose, provided that the above copyright +'\" notice and the following two paragraphs appear in all copies. +'\" +'\" 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 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. +'\" +'\" $Header: /user6/ouster/tcl/man/RCS/split.n,v 1.1 93/06/16 16:48:25 ouster Exp $ SPRITE (Berkeley) +'\" +.so man.macros +.HS split tcl +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +split \- Split a string into a proper Tcl list +.SH SYNOPSIS +\fBsplit \fIstring \fR?\fIsplitChars\fR? +.BE + +.SH DESCRIPTION +.PP +Returns a list created by splitting \fIstring\fR at each character +that is in the \fIsplitChars\fR argument. +Each element of the result list will consist of the +characters from \fIstring\fR that lie between instances of the +characters in \fIsplitChars\fR. +Empty list elements will be generated if \fIstring\fR contains +adjacent characters in \fIsplitChars\fR, or if the first or last +character of \fIstring\fR is in \fIsplitChars\fR. +If \fIsplitChars\fR is an empty string then each character of +\fIstring\fR becomes a separate element of the result list. +\fISplitChars\fR defaults to the standard white-space characters. +For example, +.DS +\fBsplit "comp.unix.misc" .\fR +.DE +returns \fB"comp unix misc"\fR and +.DS +\fBsplit "Hello world" {}\fR +.DE +returns \fB"H e l l o { } w o r l d"\fR. + +.SH KEYWORDS +list, split, string diff --git a/vendor/x11iraf/obm/Tcl/doc/string.n b/vendor/x11iraf/obm/Tcl/doc/string.n new file mode 100644 index 00000000..defd385a --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/doc/string.n @@ -0,0 +1,131 @@ +'\" +'\" Copyright (c) 1993 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 +'\" documentation for any purpose, provided that the above copyright +'\" notice and the following two paragraphs appear in all copies. +'\" +'\" 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 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. +'\" +'\" $Header: /user6/ouster/tcl/man/RCS/string.n,v 1.1 93/06/16 16:48:24 ouster Exp $ SPRITE (Berkeley) +'\" +.so man.macros +.HS string tcl +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +string \- Manipulate strings +.SH SYNOPSIS +\fBstring \fIoption arg \fR?\fIarg ...?\fR +.BE + +.SH DESCRIPTION +.PP +Performs one of several string operations, depending on \fIoption\fR. +The legal \fIoption\fRs (which may be abbreviated) are: +.TP +\fBstring compare \fIstring1 string2\fR +Perform a character-by-character comparison of strings \fIstring1\fR and +\fIstring2\fR in the same way as the C \fBstrcmp\fR procedure. Return +\-1, 0, or 1, depending on whether \fIstring1\fR is lexicographically +less than, equal to, or greater than \fIstring2\fR. +.TP +\fBstring first \fIstring1 string2\fR +Search \fIstring2\fR for a sequence of characters that exactly match +the characters in \fIstring1\fR. If found, return the index of the +first character in the first such match within \fIstring2\fR. If not +found, return \-1. +.TP +\fBstring index \fIstring charIndex\fR +Returns the \fIcharIndex\fR'th character of the \fIstring\fR +argument. A \fIcharIndex\fR of 0 corresponds to the first +character of the string. +If \fIcharIndex\fR is less than 0 or greater than +or equal to the length of the string then an empty string is +returned. +.TP +\fBstring last \fIstring1 string2\fR +Search \fIstring2\fR for a sequence of characters that exactly match +the characters in \fIstring1\fR. If found, return the index of the +first character in the last such match within \fIstring2\fR. If there +is no match, then return \-1. +.TP +\fBstring length \fIstring\fR +Returns a decimal string giving the number of characters in \fIstring\fR. +.TP +\fBstring match \fIpattern\fR \fIstring\fR +See if \fIpattern\fR matches \fIstring\fR; return 1 if it does, 0 +if it doesn't. Matching is done in a fashion similar to that +used by the C-shell. For the two strings to match, their contents +must be identical except that the following special sequences +may appear in \fIpattern\fR: +.RS +.IP \fB*\fR 10 +Matches any sequence of characters in \fIstring\fR, +including a null string. +.IP \fB?\fR 10 +Matches any single character in \fIstring\fR. +.IP \fB[\fIchars\fB]\fR 10 +Matches any character in the set given by \fIchars\fR. If a sequence +of the form +\fIx\fB\-\fIy\fR appears in \fIchars\fR, then any character +between \fIx\fR and \fIy\fR, inclusive, will match. +.IP \fB\e\fIx\fR 10 +Matches the single character \fIx\fR. This provides a way of +avoiding the special interpretation of the characters +\fB*?[]\e\fR in \fIpattern\fR. +.RE +.TP +\fBstring range \fIstring first last\fR +Returns a range of consecutive characters from \fIstring\fR, starting +with the character whose index is \fIfirst\fR and ending with the +character whose index is \fIlast\fR. An index of 0 refers to the +first character of the string. \fILast\fR may be \fBend\fR (or any +abbreviation of it) to refer to the last character of the string. +If \fIfirst\fR is less than zero then it is treated as if it were zero, and +if \fIlast\fR is greater than or equal to the length of the string then +it is treated as if it were \fBend\fR. If \fIfirst\fR is greater than +\fIlast\fR then an empty string is returned. +.TP +\fBstring tolower \fIstring\fR +Returns a value equal to \fIstring\fR except that all upper case +letters have been converted to lower case. +.TP +\fBstring toupper \fIstring\fR +Returns a value equal to \fIstring\fR except that all lower case +letters have been converted to upper case. +.TP +\fBstring trim \fIstring\fR ?\fIchars\fR? +Returns a value equal to \fIstring\fR except that any leading +or trailing characters from the set given by \fIchars\fR are +removed. +If \fIchars\fR is not specified then white space is removed +(spaces, tabs, newlines, and carriage returns). +.TP +\fBstring trimleft \fIstring\fR ?\fIchars\fR? +Returns a value equal to \fIstring\fR except that any +leading characters from the set given by \fIchars\fR are +removed. +If \fIchars\fR is not specified then white space is removed +(spaces, tabs, newlines, and carriage returns). +.TP +\fBstring trimright \fIstring\fR ?\fIchars\fR? +Returns a value equal to \fIstring\fR except that any +trailing characters from the set given by \fIchars\fR are +removed. +If \fIchars\fR is not specified then white space is removed +(spaces, tabs, newlines, and carriage returns). + +.SH KEYWORDS +case conversion, compare, index, match, pattern, string diff --git a/vendor/x11iraf/obm/Tcl/doc/switch.n b/vendor/x11iraf/obm/Tcl/doc/switch.n new file mode 100644 index 00000000..a8a5d1d9 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/doc/switch.n @@ -0,0 +1,122 @@ +'\" +'\" Copyright (c) 1993 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 +'\" documentation for any purpose, provided that the above copyright +'\" notice and the following two paragraphs appear in all copies. +'\" +'\" 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 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. +'\" +'\" $Header: /user6/ouster/tcl/man/RCS/switch.n,v 1.2 93/06/17 13:31:26 ouster Exp $ SPRITE (Berkeley) +'\" +.so man.macros +.HS switch tcl 7.0 +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +switch \- Evaluate one of several scripts, depending on a given value +.SH SYNOPSIS +\fBswitch\fI \fR?\fIoptions\fR?\fI string \fIpattern body \fR?\fIpattern body \fR...? +.br +\fBswitch\fI \fR?\fIoptions\fR?\fI string \fR{\fIpattern body \fR?\fIpattern body \fR...?} +.BE + +.SH DESCRIPTION +.PP +The \fBswitch\fR command matches its \fIstring\fR argument against each of +the \fIpattern\fR arguments in order. +As soon as it finds a \fIpattern\fR that matches \fIstring\fR it +evaluates the following \fIbody\fR argument by passing it recursively +to the Tcl interpreter and returns the result of that evaluation. +If the last \fIpattern\fR argument is \fBdefault\fR then it matches +anything. +If no \fIpattern\fR argument +matches \fIstring\fR and no default is given, then the \fBswitch\fR +command returns an empty string. +.PP +If the initial arguments to \fBswitch\fR start with \fB\-\fR then +they are treated as options. The following options are +currently supported: +.TP 10 +\fB\-exact\fR +Use exact matching when comparing \fIstring\fR to a pattern. This +is the default. +.TP 10 +\fB\-glob\fR +When matching \fIstring\fR to the patterns, use glob-style matching +(i.e. the same as implemented by the \fBstring match\fR command). +.TP 10 +\fB\-regexp\fR +When matching \fIstring\fR to the patterns, use regular +expression matching +(i.e. the same as implemented by the \fBregexp\fR command). +.TP 10 +\fB\-\|\-\fR +Marks the end of options. The argument following this one will +be treated as \fIstring\fR even if it starts with a \fB\-. +.PP +Two syntaxes are provided for the \fIpattern\fR and \fIbody\fR arguments. +The first uses a separate argument for each of the patterns and commands; +this form is convenient if substitutions are desired on some of the +patterns or commands. +The second form places all of the patterns and commands together into +a single argument; the argument must have proper list structure, with +the elements of the list being the patterns and commands. +The second form makes it easy to construct multi-line switch commands, +since the braces around the whole list make it unnecessary to include a +backslash at the end of each line. +Since the \fIpattern\fR arguments are in braces in the second form, +no command or variable substitutions are performed on them; this makes +the behavior of the second form different than the first form in some +cases. +.PP +If a \fIbody\fR is specified as ``\fB\-\fR'' it means that the \fIbody\fR +for the next pattern should also be used as the body for this +pattern (if the next pattern also has a body of ``\fB\-\fR'' +then the body after that is used, and so on). +This feature makes it possible to share a single \fIbody\fR among +several patterns. +.PP +Below are some examples of \fBswitch\fR commands: +.DS +\fBswitch\0abc\0a\0\-\0b\0{format 1}\0abc\0{format 2}\0default\0{format 3} +.DE +will return \fB2\fR, +.DS +.ta .5c 1c +\fBswitch\0\-regexp\0aaab { + ^a.*b$\0\- + b\0{format 1} + a*\0{format 2} + default\0{format 3} +} +.DE +will return \fB1\fR, and +.DS +.ta .5c 1c +\fBswitch\0xyz { + a + \- + b + {format 1} + a* + {format 2} + default + {format 3} +} +.DE +will return \fB3\fR. + +.SH KEYWORDS +switch, match, regular expression diff --git a/vendor/x11iraf/obm/Tcl/doc/tclsh.1 b/vendor/x11iraf/obm/Tcl/doc/tclsh.1 new file mode 100644 index 00000000..ba88be43 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/doc/tclsh.1 @@ -0,0 +1,103 @@ +'\" +'\" Copyright (c) 1993 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 +'\" documentation for any purpose, provided that the above copyright +'\" notice and the following two paragraphs appear in all copies. +'\" +'\" 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 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. +'\" +'\" $Header: /user6/ouster/tcl/man/RCS/tclsh.1,v 1.4 93/08/26 15:06:04 ouster Exp $ SPRITE (Berkeley) +'/" +.so man.macros +.HS tclsh tclcmds +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +tclsh \- Simple shell containing Tcl interpreter +.SH SYNOPSIS +\fBtclsh\fR ?\fIfileName arg arg ...\fR?\fR +.BE + +.SH DESCRIPTION +.PP +\fBTclsh\fR is a shell-like application that reads Tcl commands +from its standard input or from a file and evaluates them. +If invoked with no arguments then it runs interactively, reading +Tcl commands from standard input and printing command results and +error messages to standard output. +It runs until the \fBexit\fR command is invoked or until it +reaches end-of-file on its standard input. +If there exists a file \fB.tclshrc\fR in the home directory of +the user, \fBtclsh\fR evaluates the file as a Tcl script +just before reading the first command from standard input. + +.SH "SCRIPT FILES" +.PP +If \fBtclsh\fR is invoked with arguments then the first argument +is the name of a script file and any additional arguments +are made available to the script as variables (see below). +Instead of reading commands from standard input \fBtclsh\fR will +read Tcl commands from the named file; \fBtclsh\fR will exit +when it reaches the end of the file. +There is no automatic evaluation of \fB.tclshrc\fR in this +case, but the script file can always \fBsource\fR it if desired. +.PP +If you create a Tcl script in a file whose first line is +.DS +\fB#!/usr/local/bin/tclsh +.DE +then you can invoke the script file directly from your shell if +you mark the file as executable. +This assumes that \fBtclsh\fR has been installed in the default +location in /usr/local/bin; if it's installed somewhere else +then you'll have to modify the above line to match. + +.SH "VARIABLES" +.PP +\fBTclsh\fR sets the following Tcl variables: +.TP 15 +\fBargc\fR +Contains a count of the number of \fIarg\fR arguments (0 if none), +not including the name of the script file. +.TP 15 +\fBargv\fR +Contains a Tcl list whose elements are the \fIarg\fR arguments, +in order, or an empty string if there are no \fIarg\fR arguments. +.TP 15 +\fBargv0\fR +Contains \fIfileName\fR if it was specified. +Otherwise, contains the name by which \fBtclsh\fR was invoked. +.TP 15 +\fBtcl_interactive\fR +Contains 1 if \fBtclsh\fR is running interactively (no +\fIfileName\fR was specified and standard input is a terminal-like +device), 0 otherwise. +.LP + +.SH PROMPTS +.PP +When \fBtclsh\fR is invoked interactively it normally prompts for each +command with ``\fB% \fR''. You can change the prompt by setting the +variables \fBtcl_prompt1\fR and \fBtcl_prompt2\fR. If variable +\fBtcl_prompt1\fR exists then it must consist of a Tcl script +to output a prompt; instead of outputting a prompt \fBtclsh\fR +will evaluate the script in \fBtcl_prompt1\fR. +The variable \fBtcl_prompt2\fR is used in a similar way when +a newline is typed but the current command isn't yet complete; +if \fBtcl_prompt2\fR isn't set then no prompt is output for +incomplete commands. + +.SH KEYWORDS +argument, interpreter, prompt, script file, shell diff --git a/vendor/x11iraf/obm/Tcl/doc/tclvars.n b/vendor/x11iraf/obm/Tcl/doc/tclvars.n new file mode 100644 index 00000000..5b8c1e15 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/doc/tclvars.n @@ -0,0 +1,156 @@ +'\" +'\" Copyright (c) 1993 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 +'\" documentation for any purpose, provided that the above copyright +'\" notice and the following two paragraphs appear in all copies. +'\" +'\" 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 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. +'\" +'\" $Header: /user6/ouster/tcl/man/RCS/tclvars.n,v 1.1 93/06/16 16:52:49 ouster Exp $ SPRITE (Berkeley) +'\" +.so man.macros +.HS tclvars tcl +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +tclvars \- Variables used by Tcl +.BE + +.SH DESCRIPTION +.PP +The following global variables are created and managed automatically +by the Tcl library. Except where noted below, these variables should +normally be treated as read-only by application-specific code and by users. +.TP +\fBenv\fR +.br +This variable is maintained by Tcl as an array +whose elements are the environment variables for the process. +Reading an element will return the value of the corresponding +environment variable. +Setting an element of the array will modify the corresponding +environment variable or create a new one if it doesn't already +exist. +Unsetting an element of \fBenv\fR will remove the corresponding +environment variable. +Changes to the \fBenv\fR array will affect the environment +passed to children by commands like \fBexec\fR. +If the entire \fBenv\fR array is unset then Tcl will stop +monitoring \fBenv\fR accesses and will not update environment +variables. +.TP +\fBerrorCode\fR +After an error has occurred, this variable will be set to hold +additional information about the error in a form that is easy +to process with programs. +\fBerrorCode\fR consists of a Tcl list with one or more elements. +The first element of the list identifies a general class of +errors, and determines the format of the rest of the list. +The following formats for \fBerrorCode\fR are used by the +Tcl core; individual applications may define additional formats. +.RS +.TP +\fBARITH\fI code msg\fR +.VS +This format is used when an arithmetic error occurs (e.g. an attempt +to divide by zero in the \fBexpr\fR command). +\fICode\fR identifies the precise error and \fImsg\fR provides a +human-readable description of the error. \fICode\fR will be either +DIVZERO (for an attempt to divide by zero), +DOMAIN (if an argument is outside the domain of a function, such as acos(\-3)), +IOVERFLOW (for integer overflow), +OVERLFLOW (for a floating-point overflow), +or UNKNOWN (if the cause of the error cannot be determined). +.VE +.TP +\fBCHILDKILLED\fI pid sigName msg\fR +This format is used when a child process has been killed because of +a signal. The second element of \fBerrorCode\fR will be the +process's identifier (in decimal). +The third element will be the symbolic name of the signal that caused +the process to terminate; it will be one of the names from the +include file signal.h, such as \fBSIGPIPE\fR. +The fourth element will be a short human-readable message +describing the signal, such as ``write on pipe with no readers'' +for \fBSIGPIPE\fR. +.TP +\fBCHILDSTATUS\fI pid code\fR +This format is used when a child process has exited with a non-zero +exit status. The second element of \fBerrorCode\fR will be the +process's identifier (in decimal) and the third element will be the exit +code returned by the process (also in decimal). +.TP +\fBCHILDSUSP\fI pid sigName msg\fR +This format is used when a child process has been suspended because +of a signal. +The second element of \fBerrorCode\fR will be the process's identifier, +in decimal. +The third element will be the symbolic name of the signal that caused +the process to suspend; this will be one of the names from the +include file signal.h, such as \fBSIGTTIN\fR. +The fourth element will be a short human-readable message +describing the signal, such as ``background tty read'' +for \fBSIGTTIN\fR. +.TP +\fBNONE\fR +.br +This format is used for errors where no additional information is +available for an error besides the message returned with the +error. In these cases \fBerrorCode\fR will consist of a list +containing a single element whose contents are \fBNONE\fR. +.TP +\fBPOSIX \fIerrName msg\fR +.VS +If the first element of \fBerrorCode\fR is \fBPOSIX\fR, then +the error occurred during a POSIX kernel call. +.VE +The second element of the list will contain the symbolic name +of the error that occurred, such as \fBENOENT\fR; this will +be one of the values defined in the include file errno.h. +The third element of the list will be a human-readable +message corresponding to \fIerrName\fR, such as +``no such file or directory'' for the \fBENOENT\fR case. +.PP +To set \fBerrorCode\fR, applications should use library +procedures such as \fBTcl_SetErrorCode\fR and +.VS +\fBTcl_PosixError\fR, +.VE +or they may invoke the \fBerror\fR command. +If one of these methods hasn't been used, then the Tcl +interpreter will reset the variable to \fBNONE\fR after +the next error. +.RE +.TP +\fBerrorInfo\fR +After an error has occurred, this string will contain one or more lines +identifying the Tcl commands and procedures that were being executed +when the most recent error occurred. +Its contents take the form of a stack trace showing the various +nested Tcl commands that had been invoked at the time of the error. +.TP +\fBtcl_precision\fR +.VS +If this variable is set, it must contain a decimal number giving the +number of significant digits to include when converting floating-point +values to strings. +If this variable is not set then 6 digits are included. +17 digits is ``perfect'' for IEEE floating-point in that it allows +double-precision values to be converted to strings and back to +binary with no loss of precision. +.VE + +.SH KEYWORDS +arithmetic, error, environment, POSIX, precision, subprocess, variables diff --git a/vendor/x11iraf/obm/Tcl/doc/tell.n b/vendor/x11iraf/obm/Tcl/doc/tell.n new file mode 100644 index 00000000..24c3ff07 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/doc/tell.n @@ -0,0 +1,43 @@ +'\" +'\" Copyright (c) 1993 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 +'\" documentation for any purpose, provided that the above copyright +'\" notice and the following two paragraphs appear in all copies. +'\" +'\" 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 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. +'\" +'\" $Header: /user6/ouster/tcl/man/RCS/tell.n,v 1.1 93/06/16 16:48:30 ouster Exp $ SPRITE (Berkeley) +'\" +.so man.macros +.HS tell tcl +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +tell \- Return current access position for an open file +.SH SYNOPSIS +\fBtell \fIfileId\fR +.BE + +.SH DESCRIPTION +.PP +Returns a decimal string giving the current access position in +\fIfileId\fR. +\fIFileId\fR must have been the return +value from a previous call to \fBopen\fR, or it may be \fBstdin\fR, +\fBstdout\fR, or \fBstderr\fR to refer to one of the standard I/O +channels. + +.SH KEYWORDS +access position, file diff --git a/vendor/x11iraf/obm/Tcl/doc/time.n b/vendor/x11iraf/obm/Tcl/doc/time.n new file mode 100644 index 00000000..dca3c3f6 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/doc/time.n @@ -0,0 +1,46 @@ +'\" +'\" Copyright (c) 1993 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 +'\" documentation for any purpose, provided that the above copyright +'\" notice and the following two paragraphs appear in all copies. +'\" +'\" 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 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. +'\" +'\" $Header: /user6/ouster/tcl/man/RCS/time.n,v 1.1 93/06/16 16:48:29 ouster Exp $ SPRITE (Berkeley) +'\" +.so man.macros +.HS time tcl +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +time \- Time the execution of a script +.SH SYNOPSIS +\fBtime \fIscript\fR ?\fIcount\fR? +.BE + +.SH DESCRIPTION +.PP +This command will call the Tcl interpreter \fIcount\fR +times to evaluate \fIscript\fR (or once if \fIcount\fR isn't +specified). It will then return a string of the form +.DS +\fB503 microseconds per iteration\fR +.DE +which indicates the average amount of time required per iteration, +in microseconds. +Time is measured in elapsed time, not CPU time. + +.SH KEYWORDS +script, time diff --git a/vendor/x11iraf/obm/Tcl/doc/trace.n b/vendor/x11iraf/obm/Tcl/doc/trace.n new file mode 100644 index 00000000..7d8652e8 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/doc/trace.n @@ -0,0 +1,175 @@ +'\" +'\" Copyright (c) 1993 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 +'\" documentation for any purpose, provided that the above copyright +'\" notice and the following two paragraphs appear in all copies. +'\" +'\" 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 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. +'\" +'\" $Header: /user6/ouster/tcl/man/RCS/trace.n,v 1.3 93/06/16 16:36:39 ouster Exp $ SPRITE (Berkeley) +'\" +.so man.macros +.HS trace tcl +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +trace \- Monitor variable accesses +.SH SYNOPSIS +\fBtrace \fIoption\fR ?\fIarg arg ...\fR? +.BE + +.SH DESCRIPTION +.PP +This command causes Tcl commands to be executed whenever certain operations are +invoked. At present, only variable tracing is implemented. The +legal \fIoption\fR's (which may be abbreviated) are: +.TP +\fBtrace variable \fIname ops command\fR +Arrange for \fIcommand\fR to be executed whenever variable \fIname\fR +is accessed in one of the ways given by \fIops\fR. \fIName\fR may +refer to a normal variable, an element of an array, or to an array +as a whole (i.e. \fIname\fR may be just the name of an array, with no +parenthesized index). If \fIname\fR refers to a whole array, then +\fIcommand\fR is invoked whenever any element of the array is +manipulated. +.RS +.LP +\fIOps\fR indicates which operations are of interest, and consists of +one or more of the following letters: +.RS +.TP +\fBr\fR +Invoke \fIcommand\fR whenever the variable is read. +.TP +\fBw\fR +Invoke \fIcommand\fR whenever the variable is written. +.TP +\fBu\fR +Invoke \fIcommand\fR whenever the variable is unset. Variables +can be unset explicitly with the \fBunset\fR command, or +implicitly when procedures return (all of their local variables +are unset). Variables are also unset when interpreters are +deleted, but traces will not be invoked because there is no +interpreter in which to execute them. +.RE +.LP +When the trace triggers, three arguments are appended to +\fIcommand\fR so that the actual command is as follows: +.DS C +\fIcommand name1 name2 op\fR +.DE +\fIName1\fR and \fIname2\fR give the name(s) for the variable +being accessed: if the variable is a scalar then \fIname1\fR +gives the variable's name and \fIname2\fR is an empty string; +if the variable is an array element then \fIname1\fR gives the +name of the array and name2 gives the index into the array; +if an entire array is being deleted and the trace was registered +on the overall array, rather than a single element, then \fIname1\fR +gives the array name and \fIname2\fR is an empty string. +\fIOp\fR indicates what operation is being performed on the +variable, and is one of \fBr\fR, \fBw\fR, or \fBu\fR as +defined above. +.LP +\fICommand\fR executes in the same context as the code that invoked +the traced operation: if the variable was accessed as part of a +Tcl procedure, then \fIcommand\fR will have access to the same +local variables as code in the procedure. This context may be +different than the context in which the trace was created. +If \fIcommand\fR invokes a procedure (which it normally does) then +the procedure will have to use \fBupvar\fR or \fBuplevel\fR if it +wishes to access the traced variable. +Note also that \fIname1\fR may not necessarily be the same as the name +used to set the trace on the variable; differences can occur if +the access is made through a variable defined with the \fBupvar\fR +command. +.LP +For read and write traces, \fIcommand\fR can modify +the variable to affect the result of the traced operation. +If \fIcommand\fR modifies the value of a variable during a +read or write trace, then the new value will be returned as the +result of the traced operation. +The return value from \fIcommand\fR is ignored except that +if it returns an error of any sort then the traced operation +also returns an error with +.VS +the same error message returned by the trace command +.VE +(this mechanism can be used to implement read-only variables, for +example). +For write traces, \fIcommand\fR is invoked after the variable's +value has been changed; it can write a new value into the variable +to override the original value specified in the write operation. +To implement read-only variables, \fIcommand\fR will have to restore +the old value of the variable. +.LP +While \fIcommand\fR is executing during a read or write trace, traces +on the variable are temporarily disabled. +This means that reads and writes invoked by +\fIcommand\fR will occur directly, without invoking \fIcommand\fR +(or any other traces) again. +.VS +However, if \fIcommand\fR unsets the variable then unset traces +will be invoked. +.VE +.LP +When an unset trace is invoked, the variable has already been +deleted: it will appear to be undefined with no traces. +If an unset occurs because of a procedure return, then the +trace will be invoked in the variable context of the procedure +being returned to: the stack frame of the returning procedure +will no longer exist. +Traces are not disabled during unset traces, so if an unset trace +command creates a new trace and accesses the variable, the +trace will be invoked. +.VS +Any errors in unset traces are ignored. +.VE +.LP +If there are multiple traces on a variable they are invoked +in order of creation, most-recent first. +If one trace returns an error, then no further traces are +invoked for the variable. +If an array element has a trace set, and there is also a trace +set on the array as a whole, the trace on the overall array +is invoked before the one on the element. +.LP +Once created, the trace remains in effect either until the +trace is removed with the \fBtrace vdelete\fR command described +below, until the variable is unset, or until the interpreter +is deleted. +Unsetting an element of array will remove any traces on that +element, but will not remove traces on the overall array. +.LP +This command returns an empty string. +.RE +.TP +\fBtrace vdelete \fIname ops command\fR +If there is a trace set on variable \fIname\fR with the +operations and command given by \fIops\fR and \fIcommand\fR, +then the trace is removed, so that \fIcommand\fR will never +again be invoked. +Returns an empty string. +.TP +\fBtrace vinfo \fIname\fR +Returns a list containing one element for each trace +currently set on variable \fIname\fR. +Each element of the list is itself a list containing two +elements, which are the \fIops\fR and \fIcommand\fR associated +with the trace. +If \fIname\fR doesn't exist or doesn't have any traces set, then +the result of the command will be an empty string. + +.SH KEYWORDS +read, variable, write, trace, unset diff --git a/vendor/x11iraf/obm/Tcl/doc/unknown.n b/vendor/x11iraf/obm/Tcl/doc/unknown.n new file mode 100644 index 00000000..7c257575 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/doc/unknown.n @@ -0,0 +1,55 @@ +'\" +'\" Copyright (c) 1993 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 +'\" documentation for any purpose, provided that the above copyright +'\" notice and the following two paragraphs appear in all copies. +'\" +'\" 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 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. +'\" +'\" $Header: /user6/ouster/tcl/man/RCS/unknown.n,v 1.2 93/10/13 17:19:06 ouster Exp $ SPRITE (Berkeley) +'\" +.so man.macros +.HS unknown tcl +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +unknown \- Handle attempts to use non-existent commands +.SH SYNOPSIS +\fBunknown \fIcmdName \fR?\fIarg arg ...\fR? +.BE + +.SH DESCRIPTION +.PP +This command doesn't actually exist as part of Tcl, but Tcl will +invoke it if it does exist. +If the Tcl interpreter encounters a command name for which there +is not a defined command, then Tcl checks for the existence of +a command named \fBunknown\fR. +If there is no such command, then the interpreter returns an +error. +If the \fBunknown\fR command exists, then it is invoked with +arguments consisting of the fully-substituted name and arguments +for the original non-existent command. +The \fBunknown\fR command typically does things like searching +through library directories for a command procedure with the name +\fIcmdName\fR, or expanding abbreviated command names to full-length, +or automatically executing unknown commands as sub-processes. +In some cases (such as expanding abbreviations) \fBunknown\fR will +change the original command slightly and then (re-)execute it. +The result of the \fBunknown\fR command is used as the result for +the original non-existent command. + +.SH KEYWORDS +error, non-existent command diff --git a/vendor/x11iraf/obm/Tcl/doc/unset.n b/vendor/x11iraf/obm/Tcl/doc/unset.n new file mode 100644 index 00000000..ed27582e --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/doc/unset.n @@ -0,0 +1,47 @@ +'\" +'\" Copyright (c) 1993 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 +'\" documentation for any purpose, provided that the above copyright +'\" notice and the following two paragraphs appear in all copies. +'\" +'\" 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 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. +'\" +'\" $Header: /user6/ouster/tcl/man/RCS/unset.n,v 1.1 93/06/16 16:48:28 ouster Exp $ SPRITE (Berkeley) +'\" +.so man.macros +.HS unset tcl +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +unset \- Delete variables +.SH SYNOPSIS +\fBunset \fIname \fR?\fIname name ...\fR? +.BE + +.SH DESCRIPTION +.PP +This command removes one or more variables. +Each \fIname\fR is a variable name, specified in any of the +ways acceptable to the \fBset\fR command. +If a \fIname\fR refers to an element of an array then that +element is removed without affecting the rest of the array. +If a \fIname\fR consists of an array name with no parenthesized +index, then the entire array is deleted. +The \fBunset\fR command returns an empty string as result. +An error occurs if any of the variables doesn't exist, and any variables +after the non-existent one are not deleted. + +.SH KEYWORDS +remove, variable diff --git a/vendor/x11iraf/obm/Tcl/doc/uplevel.n b/vendor/x11iraf/obm/Tcl/doc/uplevel.n new file mode 100644 index 00000000..d40e966e --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/doc/uplevel.n @@ -0,0 +1,79 @@ +'\" +'\" Copyright (c) 1993 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 +'\" documentation for any purpose, provided that the above copyright +'\" notice and the following two paragraphs appear in all copies. +'\" +'\" 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 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. +'\" +'\" $Header: /user6/ouster/tcl/man/RCS/uplevel.n,v 1.1 93/06/16 16:48:27 ouster Exp $ SPRITE (Berkeley) +'\" +.so man.macros +.HS uplevel tcl +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +uplevel \- Execute a script in a different stack frame +.SH SYNOPSIS +\fBuplevel \fR?\fIlevel\fR?\fI arg \fR?\fIarg ...\fR? +.BE + +.SH DESCRIPTION +.PP +All of the \fIarg\fR arguments are concatenated as if they had +been passed to \fBconcat\fR; the result is then evaluated in the +variable context indicated by \fIlevel\fR. \fBUplevel\fR returns +the result of that evaluation. +.PP +If \fIlevel\fR is an integer then +it gives a distance (up the procedure calling stack) to move before +executing the command. If \fIlevel\fR consists of \fB#\fR followed by +a number then the number gives an absolute level number. If \fIlevel\fR +is omitted then it defaults to \fB1\fR. \fILevel\fR cannot be +defaulted if the first \fIcommand\fR argument starts with a digit or \fB#\fR. +.PP +For example, suppose that procedure \fBa\fR was invoked +from top-level, and that it called \fBb\fR, and that \fBb\fR called \fBc\fR. +Suppose that \fBc\fR invokes the \fBuplevel\fR command. If \fIlevel\fR +is \fB1\fR or \fB#2\fR or omitted, then the command will be executed +in the variable context of \fBb\fR. If \fIlevel\fR is \fB2\fR or \fB#1\fR +then the command will be executed in the variable context of \fBa\fR. +If \fIlevel\fR is \fB3\fR or \fB#0\fR then the command will be executed +at top-level (only global variables will be visible). +.PP +The \fBuplevel\fR command causes the invoking procedure to disappear +from the procedure calling stack while the command is being executed. +In the above example, suppose \fBc\fR invokes the command +.DS +\fBuplevel 1 {set x 43; d} +.DE +where \fBd\fR is another Tcl procedure. The \fBset\fR command will +modify the variable \fBx\fR in \fBb\fR's context, and \fBd\fR will execute +at level 3, as if called from \fBb\fR. If it in turn executes +the command +.DS +\fBuplevel {set x 42} +.DE +then the \fBset\fR command will modify the same variable \fBx\fR in \fBb\fR's +context: the procedure \fBc\fR does not appear to be on the call stack +when \fBd\fR is executing. The command ``\fBinfo level\fR'' may +be used to obtain the level of the current procedure. +.PP +\fBUplevel\fR makes it possible to implement new control +constructs as Tcl procedures (for example, \fBuplevel\fR could +be used to implement the \fBwhile\fR construct as a Tcl procedure). + +.SH KEYWORDS +context, stack frame, variables diff --git a/vendor/x11iraf/obm/Tcl/doc/upvar.n b/vendor/x11iraf/obm/Tcl/doc/upvar.n new file mode 100644 index 00000000..7a83ea2c --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/doc/upvar.n @@ -0,0 +1,83 @@ +'\" +'\" Copyright (c) 1993 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 +'\" documentation for any purpose, provided that the above copyright +'\" notice and the following two paragraphs appear in all copies. +'\" +'\" 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 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. +'\" +'\" $Header: /user6/ouster/tcl/man/RCS/upvar.n,v 1.3 93/06/16 16:41:13 ouster Exp $ SPRITE (Berkeley) +'\" +.so man.macros +.HS upvar tcl +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +upvar \- Create link to variable in a different stack frame +.SH SYNOPSIS +\fBupvar \fR?\fIlevel\fR? \fIotherVar myVar \fR?\fIotherVar myVar \fR...? +.BE + +.SH DESCRIPTION +.PP +This command arranges for one or more local variables in the current +procedure to refer to variables in an enclosing procedure call or +to global variables. +\fILevel\fR may have any of the forms permitted for the \fBuplevel\fR +command, and may be omitted if the first letter of the first \fIotherVar\fR +isn't \fB#\fR or a digit (it defaults to \fB1\fR). +For each \fIotherVar\fR argument, \fBupvar\fR makes the variable +by that name in the procedure frame given by \fIlevel\fR (or at +global level, if \fIlevel\fR is \fB#0\fR) accessible +in the current procedure by the name given in the corresponding +\fImyVar\fR argument. +The variable named by \fIotherVar\fR need not exist at the time of the +call; it will be created the first time \fImyVar\fR is referenced, just like +an ordinary variable. +\fBUpvar\fR may only be invoked from within procedures. +.VS +\fIMyVar\fR may not refer to an element of an array, but \fIotherVar\fR +may refer to an array element. +.VE +\fBUpvar\fR returns an empty string. +.PP +The \fBupvar\fR command simplifies the implementation of call-by-name +procedure calling and also makes it easier to build new control constructs +as Tcl procedures. +For example, consider the following procedure: +.DS +.ta 1c 2c 3c +\fBproc add2 name { + upvar $name x + set x [expr $x+2] +} +.DE +\fBAdd2\fR is invoked with an argument giving the name of a variable, +and it adds two to the value of that variable. +Although \fBadd2\fR could have been implemented using \fBuplevel\fR +instead of \fBupvar\fR, \fBupvar\fR makes it simpler for \fBadd2\fR +to access the variable in the caller's procedure frame. +.PP +.VS +If an upvar variable is unset (e.g. \fBx\fR in \fBadd2\fR above), the +\fBunset\fR operation affects the variable it is linked to, not the +upvar variable. There is no way to unset an upvar variable except +by exiting the procedure in which it is defined. However, it is +possible to retarget an upvar variable by executing another \fBupvar\fR +command. +.VE + +.SH KEYWORDS +context, frame, global, level, procedure, variable diff --git a/vendor/x11iraf/obm/Tcl/doc/while.n b/vendor/x11iraf/obm/Tcl/doc/while.n new file mode 100644 index 00000000..f1687621 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/doc/while.n @@ -0,0 +1,50 @@ +'\" +'\" Copyright (c) 1993 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 +'\" documentation for any purpose, provided that the above copyright +'\" notice and the following two paragraphs appear in all copies. +'\" +'\" 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 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. +'\" +'\" $Header: /user6/ouster/tcl/man/RCS/while.n,v 1.1 93/06/16 16:48:27 ouster Exp $ SPRITE (Berkeley) +'\" +.so man.macros +.HS while tcl +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +while \- Execute script repeatedly as long as a condition is met +.SH SYNOPSIS +\fBwhile \fItest body +.BE + +.SH DESCRIPTION +.PP +The \fIwhile\fR command evaluates \fItest\fR as an expression +(in the same way that \fBexpr\fR evaluates its argument). +The value of the expression must a proper boolean +value; if it is a true value +then \fIbody\fR is executed by passing it to the Tcl interpreter. +Once \fIbody\fR has been executed then \fItest\fR is evaluated +again, and the process repeats until eventually \fItest\fR +evaluates to a false boolean value. \fBContinue\fR +commands may be executed inside \fIbody\fR to terminate the current +iteration of the loop, and \fBbreak\fR +commands may be executed inside \fIbody\fR to cause immediate +termination of the \fBwhile\fR command. The \fBwhile\fR command +always returns an empty string. + +.SH KEYWORDS +boolean value, loop, test, while diff --git a/vendor/x11iraf/obm/Tcl/library/init.tcl b/vendor/x11iraf/obm/Tcl/library/init.tcl new file mode 100644 index 00000000..6edb37be --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/library/init.tcl @@ -0,0 +1,259 @@ +# init.tcl -- +# +# Default system startup file for Tcl-based applications. Defines +# "unknown" procedure and auto-load facilities. +# +# $Header: /user6/ouster/tcl/library/RCS/init.tcl,v 1.28 93/10/08 09:11:21 ouster Exp $ SPRITE (Berkeley) +# +# Copyright (c) 1991-1993 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. +# + +set auto_path [info library] + +# unknown: +# Invoked when a Tcl command is invoked that doesn't exist in the +# interpreter: +# +# 1. See if the autoload facility can locate the command in a +# Tcl script file. If so, load it and execute it. +# 2. See if the command exists as an executable UNIX program. +# If so, "exec" the command. +# 3. If the command was invoked at top-level: +# (a) see if the command requests csh-like history substitution +# in one of the common forms !!, !<number>, or ^old^new. If +# so, emulate csh's history substitution. +# (b) see if the command is a unique abbreviation for another +# command. If so, invoke the command. + +proc unknown args { + global auto_noexec auto_noload env unknown_pending tcl_interactive; + + set name [lindex $args 0] + if ![info exists auto_noload] { + # + # Make sure we're not trying to load the same proc twice. + # + if [info exists unknown_pending($name)] { + unset unknown_pending($name) + if {[array size unknown_pending] == 0} { + unset unknown_pending + } + return -code error "self-referential recursion in \"unknown\" for command \"$name\""; + } + set unknown_pending($name) pending; + set ret [catch {auto_load $name} msg] + unset unknown_pending($name); + if {$ret != 0} { + return -code $ret "error while autoloading \"$name\": $msg" + } + if ![array size unknown_pending] { + unset unknown_pending + } + if $msg { + return [uplevel $args] + } + } + if {([info level] == 1) && ([info script] == "") && $tcl_interactive} { + if ![info exists auto_noexec] { + if [auto_execok $name] { + return [uplevel exec >&@stdout <@stdin $args] + } + } + if {$name == "!!"} { + return [uplevel {history redo}] + } + if [regexp {^!(.+)$} $name dummy event] { + return [uplevel [list history redo $event]] + } + if [regexp {^\^([^^]*)\^([^^]*)\^?$} $name dummy old new] { + return [uplevel [list history substitute $old $new]] + } + set cmds [info commands $name*] + if {[llength $cmds] == 1} { + return [uplevel [lreplace $args 0 0 $cmds]] + } + if {[llength $cmds] != 0} { + if {$name == ""} { + return -code error "empty command name \"\"" + } else { + return -code error \ + "ambiguous command name \"$name\": [lsort $cmds]" + } + } + } + return -code error "invalid command name \"$name\"" +} + +# auto_load: +# Checks a collection of library directories to see if a procedure +# is defined in one of them. If so, it sources the appropriate +# library file to create the procedure. Returns 1 if it successfully +# loaded the procedure, 0 otherwise. + +proc auto_load cmd { + global auto_index auto_oldpath auto_path env errorInfo errorCode + + if [info exists auto_index($cmd)] { + uplevel #0 $auto_index($cmd) + return 1 + } + if [catch {set path $auto_path}] { + if [catch {set path $env(TCLLIBPATH)}] { + if [catch {set path [info library]}] { + return 0 + } + } + } + if [info exists auto_oldpath] { + if {$auto_oldpath == $path} { + return 0 + } + } + set auto_oldpath $path + catch {unset auto_index} + for {set i [expr [llength $path] - 1]} {$i >= 0} {incr i -1} { + set dir [lindex $path $i] + set f "" + if [catch {set f [open $dir/tclIndex]}] { + continue + } + 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 $dir/[lindex $line 1]" + } + } else { + error "$dir/tclIndex isn't a proper Tcl index file" + } + } msg] + if {$f != ""} { + close $f + } + if $error { + error $msg $errorInfo $errorCode + } + } + if [info exists auto_index($cmd)] { + uplevel #0 $auto_index($cmd) + if {[info commands $cmd] != ""} { + return 1 + } + } + return 0 +} + +# auto_execok: +# Returns 1 if there's an executable in the current path for the +# given name, 0 otherwise. Builds an associative array auto_execs +# that caches information about previous checks, for speed. + +proc auto_execok name { + global auto_execs env + + if [info exists auto_execs($name)] { + return $auto_execs($name) + } + set auto_execs($name) 0 + if {[string first / $name] >= 0} { + if {[file executable $name] && ![file isdirectory $name]} { + set auto_execs($name) 1 + } + return $auto_execs($name) + } + foreach dir [split $env(PATH) :] { + if {[file executable $dir/$name] && ![file isdirectory $dir/$name]} { + set auto_execs($name) 1 + return 1 + } + } + return 0 +} + +# auto_reset: +# Destroy all cached information for auto-loading and auto-execution, +# so that the information gets recomputed the next time it's needed. +# Also delete any procedures that are listed in the auto-load index +# except those related to auto-loading. + +proc auto_reset {} { + global auto_execs auto_index auto_oldpath + foreach p [info procs] { + if {[info exists auto_index($p)] && ($p != "unknown") + && ![string match auto_* $p]} { + rename $p {} + } + } + catch {unset auto_execs} + catch {unset auto_index} + catch {unset auto_oldpath} +} + +# auto_mkindex: +# Regenerate a tclIndex file from Tcl source files. Takes as argument +# the name of the directory in which the tclIndex file is to be placed, +# floowed by any number of glob patterns to use in that directory to +# locate all of the relevant files. + +proc auto_mkindex {dir args} { + global errorCode errorInfo + set oldDir [pwd] + cd $dir + set dir [pwd] + append index "# Tcl autoload index file, version 2.0\n" + append index "# This file is generated by the \"auto_mkindex\" command\n" + append index "# and sourced to set up indexing information for one or\n" + append index "# more commands. Typically each line is a command that\n" + append index "# sets an element in the auto_index array, where the\n" + append index "# element name is the name of a command and the value is\n" + append index "# a script that loads the command.\n\n" + foreach file [eval glob $args] { + set f "" + set error [catch { + set f [open $file] + while {[gets $f line] >= 0} { + if [regexp {^proc[ ]+([^ ]*)} $line match procName] { + append index "set [list auto_index($procName)]" + append index " \"source \$dir/$file\"\n" + } + } + close $f + } msg] + if $error { + set code $errorCode + set info $errorInfo + catch {close $f} + cd $oldDir + error $msg $info $code + } + } + set f [open tclIndex w] + puts $f $index nonewline + close $f + cd $oldDir +} diff --git a/vendor/x11iraf/obm/Tcl/library/parray.tcl b/vendor/x11iraf/obm/Tcl/library/parray.tcl new file mode 100644 index 00000000..b4c9f2dc --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/library/parray.tcl @@ -0,0 +1,43 @@ +# parray: +# Print the contents of a global array on stdout. +# +# $Header: /user6/ouster/tcl/library/RCS/parray.tcl,v 1.5 93/02/06 16:33:45 ouster Exp $ SPRITE (Berkeley) +# +# Copyright (c) 1991-1993 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. +# + +proc parray a { + upvar 1 $a array + if [catch {array size array}] { + error "\"$a\" isn't an array" + } + set maxl 0 + foreach name [lsort [array names array]] { + if {[string length $name] > $maxl} { + set maxl [string length $name] + } + } + set maxl [expr {$maxl + [string length $a] + 2}] + foreach name [lsort [array names array]] { + set nameString [format %s(%s) $a $name] + puts stdout [format "%-*s = %s" $maxl $nameString $array($name)] + } +} diff --git a/vendor/x11iraf/obm/Tcl/library/tclIndex b/vendor/x11iraf/obm/Tcl/library/tclIndex new file mode 100644 index 00000000..ad036dcd --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/library/tclIndex @@ -0,0 +1,14 @@ +# Tcl autoload index file, version 2.0 +# This file is generated by the "auto_mkindex" command +# and sourced to set up indexing information for one or +# more commands. Typically each line is a command that +# sets an element in the auto_index array, where the +# element name is the name of a command and the value is +# a script that loads the command. + +set auto_index(unknown) "source $dir/init.tcl" +set auto_index(auto_load) "source $dir/init.tcl" +set auto_index(auto_execok) "source $dir/init.tcl" +set auto_index(auto_reset) "source $dir/init.tcl" +set auto_index(auto_mkindex) "source $dir/init.tcl" +set auto_index(parray) "source $dir/parray.tcl" diff --git a/vendor/x11iraf/obm/Tcl/panic.c b/vendor/x11iraf/obm/Tcl/panic.c new file mode 100644 index 00000000..fa994812 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/panic.c @@ -0,0 +1,69 @@ +/* + * panic.c -- + * + * Source code for the "panic" library procedure for Tcl; + * individual applications will probably override this with + * an application-specific panic procedure. + * + * Copyright (c) 1988-1993 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. + */ + +#ifndef lint +static char rcsid[] = "$Header: /user6/ouster/tcl/RCS/panic.c,v 1.5 93/07/12 14:01:35 ouster Exp $ SPRITE (Berkeley)"; +#endif + +#include <stdio.h> +#ifdef NO_STDLIB_H +# include "compat/stdlib.h" +#else +# include <stdlib.h> +#endif + +/* + *---------------------------------------------------------------------- + * + * panic -- + * + * Print an error message and kill the process. + * + * Results: + * None. + * + * Side effects: + * The process dies, entering the debugger if possible. + * + *---------------------------------------------------------------------- + */ + + /* VARARGS ARGSUSED */ +void +panic(format, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8) + char *format; /* Format string, suitable for passing to + * fprintf. */ + char *arg1, *arg2, *arg3; /* Additional arguments (variable in number) + * to pass to fprintf. */ + char *arg4, *arg5, *arg6, *arg7, *arg8; +{ + (void) fprintf(stderr, format, arg1, arg2, arg3, arg4, arg5, arg6, + arg7, arg8); + (void) fflush(stderr); + abort(); +} diff --git a/vendor/x11iraf/obm/Tcl/patchlevel.h b/vendor/x11iraf/obm/Tcl/patchlevel.h new file mode 100644 index 00000000..24e4a0a1 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/patchlevel.h @@ -0,0 +1,11 @@ +/* + * patchlevel.h -- + * + * This file does nothing except define a "patch level" for Tcl. + * The patch level is an integer that increments with each new + * release or patch release. It's used to make sure that Tcl + * patches are applied in the correct order and only to appropriate + * sources. + */ + +#define TCL_PATCH_LEVEL 106 diff --git a/vendor/x11iraf/obm/Tcl/porting.notes b/vendor/x11iraf/obm/Tcl/porting.notes new file mode 100644 index 00000000..5e338757 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/porting.notes @@ -0,0 +1,214 @@ +This file contains a collection of notes that various people have +provided about porting Tcl to various machines and operating systems. +I don't have personal access to any of these machines, so I make +no guarantees that the notes are correct, complete, or up-to-date. +In some cases, a person has volunteered to act as a contact point +for questions about porting Tcl to a particular machine; in these +cases the person's name and e-mail address are listed. + +--------------------------------------------- +Cray machines running UNICOS: +Contact: John Freeman (jlf@cray.com) +--------------------------------------------- + +1. There is an error in the strstr function in UNICOS such that if the +string to be searched is empty (""), the search will continue past the +end of the string. Because of this, the history substitution loop +will sometimes run past the end of its target string and trash +malloc's free list, resulting in a core dump some time later. (As you +can probably guess, this took a while to diagnose.) I've submitted a +problem report to the C library maintainers, but in the meantime here +is a workaround. + +----------------------------------------------------------------- +diff -c1 -r1.1 tclHistory.c +*** 1.1 1991/11/12 16:01:58 +--- tclHistory.c 1991/11/12 16:14:22 +*************** +*** 23,24 **** +--- 23,29 ---- + #include "tclInt.h" ++ ++ #ifdef _CRAY ++ /* There is a bug in strstr in UNICOS; this works around it. */ ++ #define strstr(s1,s2) ((s1)?(*(s1)?strstr((s1),(s2)):0):0) ++ #endif _CRAY + +--------------------------------------------- +MIPS systems runing EP/IX: +--------------------------------------------- + +1. Need to add a line "#include <bsd/sys/time.h>" in tclUnix.h. + +2. Need to add "-lbsd" into the line that makes tclTest: + + ${CC} ${CFLAGS} tclTest.o libtcl.a -lbsd -o tclTest + +--------------------------------------------- +IBM RS/6000 systems running AIX: +--------------------------------------------- + +1. The system version of strtoul is buggy, at least under some +versions of AIX. If the expression tests fail, try forcing Tcl +to use its own version of strtoul instead of the system version. +To do this, first copy strtoul.c from the compat subdirectory up +to the main Tcl directory. Then modify the Makefile so that +the definition for COMPAT_OBJS includes "strtoul.o". Note: the +"config" script should now detect the buggy strtoul and substitute +Tcl's version automatically. + +2. You may have to comment out the declaration of open in tclUnix.h. + +3. You may need to add "-D_BSD -lbsd" to the CFLAGS definition. This +causes the system include files to look like BSD include files and +causes C library routines to act like bsd library routines. Without +this, the system may choke on "struct wait". + +--------------------------------------------- +AT&T 4.03 OS: +--------------------------------------------- + +Machine: i386/33Mhz i387 32k Cache 16MByte +OS: AT&T SYSV Release 4 Version 3 +X: X11R5 fixlevel 9 +Xserver: X386 1.2 + +1. Change the Tk Makefile as follows: +XLIB = -lX11 + should be changed to: +XLIB = -lX11 -lsocket -lnsl + +------------------------------------------------------- +Silicon Graphics systems: +------------------------------------------------------- + +1. Change the CC variable in the Makefile to: + +CC = cc -xansi -D__STDC__ -signed + +2. In Irix releases 4.0.1 or earlier the C compiler has a buggy optimizer. + If Tcl fails its test suite or generates inexplicable errors, + compile tclVar.c with -O0 instead of -O. + +3. For IRIX 5.1 or later, comments 1 and 2 are no longer relevant, +but you must add -D_BSD_SIGNALS to CFLAGS to get the proper signal +routines. + +4. Add a "-lsun" switch in the targets for tclsh and tcltest, +just before ${MATH_LIBS}. + +--------------------------------------------- +NeXT machines running NeXTStep 3.1: +--------------------------------------------- + +1. Run configure with predefined CPP: + CPP='cc -E' ./configure + +2. Edit Makefile: + -add tmpnam.o to COMPAT_OBJS: + COMPAT_OBJS = getcwd.o waitpid.o strtod.o tmpnam.o + -add '-m' to MATH_LIBS + MATH_LIBS = -m -lm + +3. Edit compat/tmpnam.o and replace "/usr/tmp" with "/tmp" + +After this, tcl7.0 will be build fine on NeXT (ignore linker warning) +and run all the tests. There are some formatting problems in printf() or +scanf() which come from NeXT's lacking POSIX conformance. Ignore those +errors, they don't matter much. + +------------------------------------------------- +ISC 2.2 UNIX (using standard ATT SYSV compiler): +------------------------------------------------- + +In Makefile, change + +CFLAGS = -g -I. -DTCL_LIBRARY=\"${TCL_LIBRARY}\" + +to + +CFLAGS = -g -I. -DPOSIX_JC -DTCL_LIBRARY=\"${TCL_LIBRARY}\" + +This brings in the typedef for pid_t, which is needed for +/usr/include/sys/wait.h in tclUnix.h. + +--------------------------------------------- +DEC Alphas: +--------------------------------------------- + +1. There appears to be a compiler/library bug that causes core-dumps +unless you compile tclVar.c without optimization (remove the -O compiler +switch). The problem appears to have been fixed in the 1.3-4 version +of the compiler. + +--------------------------------------------- +CDC 4680MNP, EP/IX 1.4.3: +--------------------------------------------- + +The installation was done in the System V environment (-systype sysv) +with the BSD extensions available (-I/usr/include/bsd and -lbsd). It was +built with the 2.20 level C compiler. The 2.11 level should not be used +because it has a problem with detecting NaN values in lines like: + if (x != x) ... +which appear in the TCL code. + +To make the configure script find the BSD extensions, I set environment +variable DEFS to "-I/usr/include/bsd" and LIBS to "-lbsd" before +running it. I would have also set CC to "cc2.20", but that compiler +driver has a bug that loader errors (e.g. not finding a library routine, +which the script uses to tell what is available) do not cause an error +status to be returned to the shell. + +There is a bug in the <sys/wait.h> include file that mis-defines the +structure fields and causes WIFEXITED and WIFSIGNALED to return incorrect +values. My solution was to create a subdirectory "sys" of the main TCL +source directory and put a corrected wait.h in it. The "-I." already on +all the compile lines causes it to be used instead of the system version. +To fix this, compare the structure definition in /usr/include/bsd/sys/wait.h +with /bsd43/include/sys/wait.h (or mail to John Jackson, jrj@cc.purdue.edu, +and he'll send you a context diff). + +After running configure, I made the following changes to Makefile: + + 1) In AC_FLAGS, change: + -DNO_WAIT3=1 + to + -DNO_WAIT3=0 -Dwait3=wait2 + EP/IX (in the System V environment) provides a wait2() system + call with what TCL needs (the WNOHANG flag). The extra parameter + TCL passes to what it thinks is wait3() (the resources used by + the child process) is always zero and will be safely ignored. + + 3) Change: + CC=cc + to + CC=cc2.20 + because of the NaN problem mentioned earlier. Skip this if the + default compiler is already 2.20 (or later). + + 4) Add "-lbsd" to the commands that create tclsh and tcltest + (look for "-o"). + +--------------------------------------------- +Convex systems, OS 10.1 and 10.2: +Contact: Lennart Sorth (ls@dmi.min.dk) +--------------------------------------------- + +1. tcl7.0b2 compiles on Convex systems (OS 10.1 and 10.2) by just running + configure, typing make, except tclUnixUtil.c needs to be compiled + with option "-pcc" (portable cc, =!ANSI) due to: + cc: Error on line 1111 of tclUnixUtil.c: 'waitpid' redeclared: + incompatible types. + +------------------------------------------------- +Pyramid, OSx 5.1a (UCB universe, GCC installed): +------------------------------------------------- + +1. The procedures memcpy, strchr, fmod, and strrchr are all missing, +so you'll need to provide substitutes for them. After you do that +everything should compile fine. There will be one error in a scan +test, but it's an obscure one because of a non-ANSI implementation +of sscanf on the machine; you can ignore it. + +2. You may also have to add "tmpnam.o" to COMPAT_OBJS in Makefile: +the system version appears to be bad. diff --git a/vendor/x11iraf/obm/Tcl/regexp.c b/vendor/x11iraf/obm/Tcl/regexp.c new file mode 100644 index 00000000..6dc0e291 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/regexp.c @@ -0,0 +1,1233 @@ +/* + * TclRegComp and TclRegExec -- TclRegSub and TclRegError are elsewhere + * + * Copyright (c) 1986 by University of Toronto. + * Written by Henry Spencer. Not derived from licensed software. + * + * Permission is granted to anyone to use this software for any + * purpose on any computer system, and to redistribute it freely, + * subject to the following restrictions: + * + * 1. The author is not responsible for the consequences of use of + * this software, no matter how awful, even if they arise + * from defects in it. + * + * 2. The origin of this software must not be misrepresented, either + * by explicit claim or by omission. + * + * 3. Altered versions must be plainly marked as such, and must not + * be misrepresented as being the original software. + * + * Beware that some of this code is subtly aware of the way operator + * precedence is structured in regular expressions. Serious changes in + * regular-expression syntax might require a total rethink. + * + * *** NOTE: this code has been altered slightly for use in Tcl: *** + * *** 1. Use ckalloc and ckfree instead of malloc and free. *** + * *** 2. Add extra argument to regexp to specify the real *** + * *** start of the string separately from the start of the *** + * *** current search. This is needed to search for multiple *** + * *** matches within a string. *** + * *** 3. Names have been changed, e.g. from regcomp to *** + * *** TclRegComp, to avoid clashes with other *** + * *** regexp implementations used by applications. *** + */ +#include "tclInt.h" + +/* + * The "internal use only" fields in regexp.h are present to pass info from + * compile to execute that permits the execute phase to run lots faster on + * simple cases. They are: + * + * regstart char that must begin a match; '\0' if none obvious + * reganch is the match anchored (at beginning-of-line only)? + * regmust string (pointer into program) that match must include, or NULL + * regmlen length of regmust string + * + * Regstart and reganch permit very fast decisions on suitable starting points + * for a match, cutting down the work a lot. Regmust permits fast rejection + * of lines that cannot possibly match. The regmust tests are costly enough + * that TclRegComp() supplies a regmust only if the r.e. contains something + * potentially expensive (at present, the only such thing detected is * or + + * at the start of the r.e., which can involve a lot of backup). Regmlen is + * supplied because the test in TclRegExec() needs it and TclRegComp() is + * computing it anyway. + */ + +/* + * Structure for regexp "program". This is essentially a linear encoding + * of a nondeterministic finite-state machine (aka syntax charts or + * "railroad normal form" in parsing technology). Each node is an opcode + * plus a "next" pointer, possibly plus an operand. "Next" pointers of + * all nodes except BRANCH implement concatenation; a "next" pointer with + * a BRANCH on both ends of it is connecting two alternatives. (Here we + * have one of the subtle syntax dependencies: an individual BRANCH (as + * opposed to a collection of them) is never concatenated with anything + * because of operator precedence.) The operand of some types of node is + * a literal string; for others, it is a node leading into a sub-FSM. In + * particular, the operand of a BRANCH node is the first node of the branch. + * (NB this is *not* a tree structure: the tail of the branch connects + * to the thing following the set of BRANCHes.) The opcodes are: + */ + +/* definition number opnd? meaning */ +#define END 0 /* no End of program. */ +#define BOL 1 /* no Match "" at beginning of line. */ +#define EOL 2 /* no Match "" at end of line. */ +#define ANY 3 /* no Match any one character. */ +#define ANYOF 4 /* str Match any character in this string. */ +#define ANYBUT 5 /* str Match any character not in this string. */ +#define BRANCH 6 /* node Match this alternative, or the next... */ +#define BACK 7 /* no Match "", "next" ptr points backward. */ +#define EXACTLY 8 /* str Match this string. */ +#define NOTHING 9 /* no Match empty string. */ +#define STAR 10 /* node Match this (simple) thing 0 or more times. */ +#define PLUS 11 /* node Match this (simple) thing 1 or more times. */ +#define OPEN 20 /* no Mark this point in input as start of #n. */ + /* OPEN+1 is number 1, etc. */ +#define CLOSE 30 /* no Analogous to OPEN. */ + +/* + * Opcode notes: + * + * BRANCH The set of branches constituting a single choice are hooked + * together with their "next" pointers, since precedence prevents + * anything being concatenated to any individual branch. The + * "next" pointer of the last BRANCH in a choice points to the + * thing following the whole choice. This is also where the + * final "next" pointer of each individual branch points; each + * branch starts with the operand node of a BRANCH node. + * + * BACK Normal "next" pointers all implicitly point forward; BACK + * exists to make loop structures possible. + * + * STAR,PLUS '?', and complex '*' and '+', are implemented as circular + * BRANCH structures using BACK. Simple cases (one character + * per match) are implemented with STAR and PLUS for speed + * and to minimize recursive plunges. + * + * OPEN,CLOSE ...are numbered at compile time. + */ + +/* + * A node is one char of opcode followed by two chars of "next" pointer. + * "Next" pointers are stored as two 8-bit pieces, high order first. The + * value is a positive offset from the opcode of the node containing it. + * An operand, if any, simply follows the node. (Note that much of the + * code generation knows about this implicit relationship.) + * + * Using two bytes for the "next" pointer is vast overkill for most things, + * but allows patterns to get big without disasters. + */ +#define OP(p) (*(p)) +#define NEXT(p) (((*((p)+1)&0377)<<8) + (*((p)+2)&0377)) +#define OPERAND(p) ((p) + 3) + +/* + * See regmagic.h for one further detail of program structure. + */ + + +/* + * Utility definitions. + */ +#ifndef CHARBITS +#define UCHARAT(p) ((int)*(unsigned char *)(p)) +#else +#define UCHARAT(p) ((int)*(p)&CHARBITS) +#endif + +#define FAIL(m) { TclRegError(m); return(NULL); } +#define ISMULT(c) ((c) == '*' || (c) == '+' || (c) == '?') +#define META "^$.[()|?+*\\" + +/* + * Flags to be passed up and down. + */ +#define HASWIDTH 01 /* Known never to match null string. */ +#define SIMPLE 02 /* Simple enough to be STAR/PLUS operand. */ +#define SPSTART 04 /* Starts with * or +. */ +#define WORST 0 /* Worst case. */ + +/* + * Global work variables for TclRegComp(). + */ +static char *regparse; /* Input-scan pointer. */ +static int regnpar; /* () count. */ +static char regdummy; +static char *regcode; /* Code-emit pointer; ®dummy = don't. */ +static long regsize; /* Code size. */ + +/* + * The first byte of the regexp internal "program" is actually this magic + * number; the start node begins in the second byte. + */ +#define MAGIC 0234 + + +/* + * Forward declarations for TclRegComp()'s friends. + */ +#ifndef STATIC +#define STATIC static +#endif +STATIC char *reg(); +STATIC char *regbranch(); +STATIC char *regpiece(); +STATIC char *regatom(); +STATIC char *regnode(); +STATIC char *regnext(); +STATIC void regc(); +STATIC void reginsert(); +STATIC void regtail(); +STATIC void regoptail(); +#ifdef STRCSPN +STATIC int strcspn(); +#endif + +/* + - TclRegComp - compile a regular expression into internal code + * + * We can't allocate space until we know how big the compiled form will be, + * but we can't compile it (and thus know how big it is) until we've got a + * place to put the code. So we cheat: we compile it twice, once with code + * generation turned off and size counting turned on, and once "for real". + * This also means that we don't allocate space until we are sure that the + * thing really will compile successfully, and we never have to move the + * code and thus invalidate pointers into it. (Note that it has to be in + * one piece because free() must be able to free it all.) + * + * Beware that the optimization-preparation code in here knows about some + * of the structure of the compiled regexp. + */ +regexp * +TclRegComp(exp) +char *exp; +{ + register regexp *r; + register char *scan; + register char *longest; + register int len; + int flags; + + if (exp == NULL) + FAIL("NULL argument"); + + /* First pass: determine size, legality. */ + regparse = exp; + regnpar = 1; + regsize = 0L; + regcode = ®dummy; + regc(MAGIC); + if (reg(0, &flags) == NULL) + return(NULL); + + /* Small enough for pointer-storage convention? */ + if (regsize >= 32767L) /* Probably could be 65535L. */ + FAIL("regexp too big"); + + /* Allocate space. */ + r = (regexp *)ckalloc(sizeof(regexp) + (unsigned)regsize); + if (r == NULL) + FAIL("out of space"); + + /* Second pass: emit code. */ + regparse = exp; + regnpar = 1; + regcode = r->program; + regc(MAGIC); + if (reg(0, &flags) == NULL) + return(NULL); + + /* Dig out information for optimizations. */ + r->regstart = '\0'; /* Worst-case defaults. */ + r->reganch = 0; + r->regmust = NULL; + r->regmlen = 0; + scan = r->program+1; /* First BRANCH. */ + if (OP(regnext(scan)) == END) { /* Only one top-level choice. */ + scan = OPERAND(scan); + + /* Starting-point info. */ + if (OP(scan) == EXACTLY) + r->regstart = *OPERAND(scan); + else if (OP(scan) == BOL) + r->reganch++; + + /* + * If there's something expensive in the r.e., find the + * longest literal string that must appear and make it the + * regmust. Resolve ties in favor of later strings, since + * the regstart check works with the beginning of the r.e. + * and avoiding duplication strengthens checking. Not a + * strong reason, but sufficient in the absence of others. + */ + if (flags&SPSTART) { + longest = NULL; + len = 0; + for (; scan != NULL; scan = regnext(scan)) + if (OP(scan) == EXACTLY && ((int) strlen(OPERAND(scan))) >= len) { + longest = OPERAND(scan); + len = strlen(OPERAND(scan)); + } + r->regmust = longest; + r->regmlen = len; + } + } + + return(r); +} + +/* + - reg - regular expression, i.e. main body or parenthesized thing + * + * Caller must absorb opening parenthesis. + * + * Combining parenthesis handling with the base level of regular expression + * is a trifle forced, but the need to tie the tails of the branches to what + * follows makes it hard to avoid. + */ +static char * +reg(paren, flagp) +int paren; /* Parenthesized? */ +int *flagp; +{ + register char *ret; + register char *br; + register char *ender; + register int parno = 0; + int flags; + + *flagp = HASWIDTH; /* Tentatively. */ + + /* Make an OPEN node, if parenthesized. */ + if (paren) { + if (regnpar >= NSUBEXP) + FAIL("too many ()"); + parno = regnpar; + regnpar++; + ret = regnode(OPEN+parno); + } else + ret = NULL; + + /* Pick up the branches, linking them together. */ + br = regbranch(&flags); + if (br == NULL) + return(NULL); + if (ret != NULL) + regtail(ret, br); /* OPEN -> first. */ + else + ret = br; + if (!(flags&HASWIDTH)) + *flagp &= ~HASWIDTH; + *flagp |= flags&SPSTART; + while (*regparse == '|') { + regparse++; + br = regbranch(&flags); + if (br == NULL) + return(NULL); + regtail(ret, br); /* BRANCH -> BRANCH. */ + if (!(flags&HASWIDTH)) + *flagp &= ~HASWIDTH; + *flagp |= flags&SPSTART; + } + + /* Make a closing node, and hook it on the end. */ + ender = regnode((paren) ? CLOSE+parno : END); + regtail(ret, ender); + + /* Hook the tails of the branches to the closing node. */ + for (br = ret; br != NULL; br = regnext(br)) + regoptail(br, ender); + + /* Check for proper termination. */ + if (paren && *regparse++ != ')') { + FAIL("unmatched ()"); + } else if (!paren && *regparse != '\0') { + if (*regparse == ')') { + FAIL("unmatched ()"); + } else + FAIL("junk on end"); /* "Can't happen". */ + /* NOTREACHED */ + } + + return(ret); +} + +/* + - regbranch - one alternative of an | operator + * + * Implements the concatenation operator. + */ +static char * +regbranch(flagp) +int *flagp; +{ + register char *ret; + register char *chain; + register char *latest; + int flags; + + *flagp = WORST; /* Tentatively. */ + + ret = regnode(BRANCH); + chain = NULL; + while (*regparse != '\0' && *regparse != '|' && *regparse != ')') { + latest = regpiece(&flags); + if (latest == NULL) + return(NULL); + *flagp |= flags&HASWIDTH; + if (chain == NULL) /* First piece. */ + *flagp |= flags&SPSTART; + else + regtail(chain, latest); + chain = latest; + } + if (chain == NULL) /* Loop ran zero times. */ + (void) regnode(NOTHING); + + return(ret); +} + +/* + - regpiece - something followed by possible [*+?] + * + * Note that the branching code sequences used for ? and the general cases + * of * and + are somewhat optimized: they use the same NOTHING node as + * both the endmarker for their branch list and the body of the last branch. + * It might seem that this node could be dispensed with entirely, but the + * endmarker role is not redundant. + */ +static char * +regpiece(flagp) +int *flagp; +{ + register char *ret; + register char op; + register char *next; + int flags; + + ret = regatom(&flags); + if (ret == NULL) + return(NULL); + + op = *regparse; + if (!ISMULT(op)) { + *flagp = flags; + return(ret); + } + + if (!(flags&HASWIDTH) && op != '?') + FAIL("*+ operand could be empty"); + *flagp = (op != '+') ? (WORST|SPSTART) : (WORST|HASWIDTH); + + if (op == '*' && (flags&SIMPLE)) + reginsert(STAR, ret); + else if (op == '*') { + /* Emit x* as (x&|), where & means "self". */ + reginsert(BRANCH, ret); /* Either x */ + regoptail(ret, regnode(BACK)); /* and loop */ + regoptail(ret, ret); /* back */ + regtail(ret, regnode(BRANCH)); /* or */ + regtail(ret, regnode(NOTHING)); /* null. */ + } else if (op == '+' && (flags&SIMPLE)) + reginsert(PLUS, ret); + else if (op == '+') { + /* Emit x+ as x(&|), where & means "self". */ + next = regnode(BRANCH); /* Either */ + regtail(ret, next); + regtail(regnode(BACK), ret); /* loop back */ + regtail(next, regnode(BRANCH)); /* or */ + regtail(ret, regnode(NOTHING)); /* null. */ + } else if (op == '?') { + /* Emit x? as (x|) */ + reginsert(BRANCH, ret); /* Either x */ + regtail(ret, regnode(BRANCH)); /* or */ + next = regnode(NOTHING); /* null. */ + regtail(ret, next); + regoptail(ret, next); + } + regparse++; + if (ISMULT(*regparse)) + FAIL("nested *?+"); + + return(ret); +} + +/* + - regatom - the lowest level + * + * Optimization: gobbles an entire sequence of ordinary characters so that + * it can turn them into a single node, which is smaller to store and + * faster to run. Backslashed characters are exceptions, each becoming a + * separate node; the code is simpler that way and it's not worth fixing. + */ +static char * +regatom(flagp) +int *flagp; +{ + register char *ret; + int flags; + + *flagp = WORST; /* Tentatively. */ + + switch (*regparse++) { + case '^': + ret = regnode(BOL); + break; + case '$': + ret = regnode(EOL); + break; + case '.': + ret = regnode(ANY); + *flagp |= HASWIDTH|SIMPLE; + break; + case '[': { + register int clss; + register int classend; + + if (*regparse == '^') { /* Complement of range. */ + ret = regnode(ANYBUT); + regparse++; + } else + ret = regnode(ANYOF); + if (*regparse == ']' || *regparse == '-') + regc(*regparse++); + while (*regparse != '\0' && *regparse != ']') { + if (*regparse == '-') { + regparse++; + if (*regparse == ']' || *regparse == '\0') + regc('-'); + else { + clss = UCHARAT(regparse-2)+1; + classend = UCHARAT(regparse); + if (clss > classend+1) + FAIL("invalid [] range"); + for (; clss <= classend; clss++) + regc(clss); + regparse++; + } + } else + regc(*regparse++); + } + regc('\0'); + if (*regparse != ']') + FAIL("unmatched []"); + regparse++; + *flagp |= HASWIDTH|SIMPLE; + } + break; + case '(': + ret = reg(1, &flags); + if (ret == NULL) + return(NULL); + *flagp |= flags&(HASWIDTH|SPSTART); + break; + case '\0': + case '|': + case ')': + FAIL("internal urp"); /* Supposed to be caught earlier. */ + /* NOTREACHED */ + break; + case '?': + case '+': + case '*': + FAIL("?+* follows nothing"); + /* NOTREACHED */ + break; + case '\\': + if (*regparse == '\0') + FAIL("trailing \\"); + ret = regnode(EXACTLY); + regc(*regparse++); + regc('\0'); + *flagp |= HASWIDTH|SIMPLE; + break; + default: { + register int len; + register char ender; + + regparse--; + len = strcspn(regparse, META); + if (len <= 0) + FAIL("internal disaster"); + ender = *(regparse+len); + if (len > 1 && ISMULT(ender)) + len--; /* Back off clear of ?+* operand. */ + *flagp |= HASWIDTH; + if (len == 1) + *flagp |= SIMPLE; + ret = regnode(EXACTLY); + while (len > 0) { + regc(*regparse++); + len--; + } + regc('\0'); + } + break; + } + + return(ret); +} + +/* + - regnode - emit a node + */ +static char * /* Location. */ +regnode(op) +char op; +{ + register char *ret; + register char *ptr; + + ret = regcode; + if (ret == ®dummy) { + regsize += 3; + return(ret); + } + + ptr = ret; + *ptr++ = op; + *ptr++ = '\0'; /* Null "next" pointer. */ + *ptr++ = '\0'; + regcode = ptr; + + return(ret); +} + +/* + - regc - emit (if appropriate) a byte of code + */ +static void +regc(b) +char b; +{ + if (regcode != ®dummy) + *regcode++ = b; + else + regsize++; +} + +/* + - reginsert - insert an operator in front of already-emitted operand + * + * Means relocating the operand. + */ +static void +reginsert(op, opnd) +char op; +char *opnd; +{ + register char *src; + register char *dst; + register char *place; + + if (regcode == ®dummy) { + regsize += 3; + return; + } + + src = regcode; + regcode += 3; + dst = regcode; + while (src > opnd) + *--dst = *--src; + + place = opnd; /* Op node, where operand used to be. */ + *place++ = op; + *place++ = '\0'; + *place++ = '\0'; +} + +/* + - regtail - set the next-pointer at the end of a node chain + */ +static void +regtail(p, val) +char *p; +char *val; +{ + register char *scan; + register char *temp; + register int offset; + + if (p == ®dummy) + return; + + /* Find last node. */ + scan = p; + for (;;) { + temp = regnext(scan); + if (temp == NULL) + break; + scan = temp; + } + + if (OP(scan) == BACK) + offset = scan - val; + else + offset = val - scan; + *(scan+1) = (offset>>8)&0377; + *(scan+2) = offset&0377; +} + +/* + - regoptail - regtail on operand of first argument; nop if operandless + */ +static void +regoptail(p, val) +char *p; +char *val; +{ + /* "Operandless" and "op != BRANCH" are synonymous in practice. */ + if (p == NULL || p == ®dummy || OP(p) != BRANCH) + return; + regtail(OPERAND(p), val); +} + +/* + * TclRegExec and friends + */ + +/* + * Global work variables for TclRegExec(). + */ +static char *reginput; /* String-input pointer. */ +static char *regbol; /* Beginning of input, for ^ check. */ +static char **regstartp; /* Pointer to startp array. */ +static char **regendp; /* Ditto for endp. */ + +/* + * Forwards. + */ +STATIC int regtry(); +STATIC int regmatch(); +STATIC int regrepeat(); + +#ifdef DEBUG +int regnarrate = 0; +void regdump(); +STATIC char *regprop(); +#endif + +/* + - TclRegExec - match a regexp against a string + */ +int +TclRegExec(prog, string, start) +register regexp *prog; +register char *string; +char *start; +{ + register char *s; + + /* Be paranoid... */ + if (prog == NULL || string == NULL) { + TclRegError("NULL parameter"); + return(0); + } + + /* Check validity of program. */ + if (UCHARAT(prog->program) != MAGIC) { + TclRegError("corrupted program"); + return(0); + } + + /* If there is a "must appear" string, look for it. */ + if (prog->regmust != NULL) { + s = string; + while ((s = strchr(s, prog->regmust[0])) != NULL) { + if (strncmp(s, prog->regmust, prog->regmlen) == 0) + break; /* Found it. */ + s++; + } + if (s == NULL) /* Not present. */ + return(0); + } + + /* Mark beginning of line for ^ . */ + regbol = start; + + /* Simplest case: anchored match need be tried only once. */ + if (prog->reganch) + return(regtry(prog, string)); + + /* Messy cases: unanchored match. */ + s = string; + if (prog->regstart != '\0') + /* We know what char it must start with. */ + while ((s = strchr(s, prog->regstart)) != NULL) { + if (regtry(prog, s)) + return(1); + s++; + } + else + /* We don't -- general case. */ + do { + if (regtry(prog, s)) + return(1); + } while (*s++ != '\0'); + + /* Failure. */ + return(0); +} + +/* + - regtry - try match at specific point + */ +static int /* 0 failure, 1 success */ +regtry(prog, string) +regexp *prog; +char *string; +{ + register int i; + register char **sp; + register char **ep; + + reginput = string; + regstartp = prog->startp; + regendp = prog->endp; + + sp = prog->startp; + ep = prog->endp; + for (i = NSUBEXP; i > 0; i--) { + *sp++ = NULL; + *ep++ = NULL; + } + if (regmatch(prog->program + 1)) { + prog->startp[0] = string; + prog->endp[0] = reginput; + return(1); + } else + return(0); +} + +/* + - regmatch - main matching routine + * + * Conceptually the strategy is simple: check to see whether the current + * node matches, call self recursively to see whether the rest matches, + * and then act accordingly. In practice we make some effort to avoid + * recursion, in particular by going through "ordinary" nodes (that don't + * need to know whether the rest of the match failed) by a loop instead of + * by recursion. + */ +static int /* 0 failure, 1 success */ +regmatch(prog) +char *prog; +{ + register char *scan; /* Current node. */ + char *next; /* Next node. */ + + scan = prog; +#ifdef DEBUG + if (scan != NULL && regnarrate) + fprintf(stderr, "%s(\n", regprop(scan)); +#endif + while (scan != NULL) { +#ifdef DEBUG + if (regnarrate) + fprintf(stderr, "%s...\n", regprop(scan)); +#endif + next = regnext(scan); + + switch (OP(scan)) { + case BOL: + if (reginput != regbol) + return(0); + break; + case EOL: + if (*reginput != '\0') + return(0); + break; + case ANY: + if (*reginput == '\0') + return(0); + reginput++; + break; + case EXACTLY: { + register int len; + register char *opnd; + + opnd = OPERAND(scan); + /* Inline the first character, for speed. */ + if (*opnd != *reginput) + return(0); + len = strlen(opnd); + if (len > 1 && strncmp(opnd, reginput, len) != 0) + return(0); + reginput += len; + } + break; + case ANYOF: + if (*reginput == '\0' || strchr(OPERAND(scan), *reginput) == NULL) + return(0); + reginput++; + break; + case ANYBUT: + if (*reginput == '\0' || strchr(OPERAND(scan), *reginput) != NULL) + return(0); + reginput++; + break; + case NOTHING: + break; + case BACK: + break; + case OPEN+1: + case OPEN+2: + case OPEN+3: + case OPEN+4: + case OPEN+5: + case OPEN+6: + case OPEN+7: + case OPEN+8: + case OPEN+9: { + register int no; + register char *save; + + no = OP(scan) - OPEN; + save = reginput; + + if (regmatch(next)) { + /* + * Don't set startp if some later + * invocation of the same parentheses + * already has. + */ + if (regstartp[no] == NULL) + regstartp[no] = save; + return(1); + } else + return(0); + } + /* NOTREACHED */ + break; + case CLOSE+1: + case CLOSE+2: + case CLOSE+3: + case CLOSE+4: + case CLOSE+5: + case CLOSE+6: + case CLOSE+7: + case CLOSE+8: + case CLOSE+9: { + register int no; + register char *save; + + no = OP(scan) - CLOSE; + save = reginput; + + if (regmatch(next)) { + /* + * Don't set endp if some later + * invocation of the same parentheses + * already has. + */ + if (regendp[no] == NULL) + regendp[no] = save; + return(1); + } else + return(0); + } + /* NOTREACHED */ + break; + case BRANCH: { + register char *save; + + if (OP(next) != BRANCH) /* No choice. */ + next = OPERAND(scan); /* Avoid recursion. */ + else { + do { + save = reginput; + if (regmatch(OPERAND(scan))) + return(1); + reginput = save; + scan = regnext(scan); + } while (scan != NULL && OP(scan) == BRANCH); + return(0); + /* NOTREACHED */ + } + } + /* NOTREACHED */ + break; + case STAR: + case PLUS: { + register char nextch; + register int no; + register char *save; + register int min; + + /* + * Lookahead to avoid useless match attempts + * when we know what character comes next. + */ + nextch = '\0'; + if (OP(next) == EXACTLY) + nextch = *OPERAND(next); + min = (OP(scan) == STAR) ? 0 : 1; + save = reginput; + no = regrepeat(OPERAND(scan)); + while (no >= min) { + /* If it could work, try it. */ + if (nextch == '\0' || *reginput == nextch) + if (regmatch(next)) + return(1); + /* Couldn't or didn't -- back up. */ + no--; + reginput = save + no; + } + return(0); + } + /* NOTREACHED */ + break; + case END: + return(1); /* Success! */ + /* NOTREACHED */ + break; + default: + TclRegError("memory corruption"); + return(0); + /* NOTREACHED */ + break; + } + + scan = next; + } + + /* + * We get here only if there's trouble -- normally "case END" is + * the terminating point. + */ + TclRegError("corrupted pointers"); + return(0); +} + +/* + - regrepeat - repeatedly match something simple, report how many + */ +static int +regrepeat(p) +char *p; +{ + register int count = 0; + register char *scan; + register char *opnd; + + scan = reginput; + opnd = OPERAND(p); + switch (OP(p)) { + case ANY: + count = strlen(scan); + scan += count; + break; + case EXACTLY: + while (*opnd == *scan) { + count++; + scan++; + } + break; + case ANYOF: + while (*scan != '\0' && strchr(opnd, *scan) != NULL) { + count++; + scan++; + } + break; + case ANYBUT: + while (*scan != '\0' && strchr(opnd, *scan) == NULL) { + count++; + scan++; + } + break; + default: /* Oh dear. Called inappropriately. */ + TclRegError("internal foulup"); + count = 0; /* Best compromise. */ + break; + } + reginput = scan; + + return(count); +} + +/* + - regnext - dig the "next" pointer out of a node + */ +static char * +regnext(p) +register char *p; +{ + register int offset; + + if (p == ®dummy) + return(NULL); + + offset = NEXT(p); + if (offset == 0) + return(NULL); + + if (OP(p) == BACK) + return(p-offset); + else + return(p+offset); +} + +#ifdef DEBUG + +STATIC char *regprop(); + +/* + - regdump - dump a regexp onto stdout in vaguely comprehensible form + */ +void +regdump(r) +regexp *r; +{ + register char *s; + register char op = EXACTLY; /* Arbitrary non-END op. */ + register char *next; + + + s = r->program + 1; + while (op != END) { /* While that wasn't END last time... */ + op = OP(s); + printf("%2d%s", s-r->program, regprop(s)); /* Where, what. */ + next = regnext(s); + if (next == NULL) /* Next ptr. */ + printf("(0)"); + else + printf("(%d)", (s-r->program)+(next-s)); + s += 3; + if (op == ANYOF || op == ANYBUT || op == EXACTLY) { + /* Literal string, where present. */ + while (*s != '\0') { + putchar(*s); + s++; + } + s++; + } + putchar('\n'); + } + + /* Header fields of interest. */ + if (r->regstart != '\0') + printf("start `%c' ", r->regstart); + if (r->reganch) + printf("anchored "); + if (r->regmust != NULL) + printf("must have \"%s\"", r->regmust); + printf("\n"); +} + +/* + - regprop - printable representation of opcode + */ +static char * +regprop(op) +char *op; +{ + register char *p; + static char buf[50]; + + (void) strcpy(buf, ":"); + + switch (OP(op)) { + case BOL: + p = "BOL"; + break; + case EOL: + p = "EOL"; + break; + case ANY: + p = "ANY"; + break; + case ANYOF: + p = "ANYOF"; + break; + case ANYBUT: + p = "ANYBUT"; + break; + case BRANCH: + p = "BRANCH"; + break; + case EXACTLY: + p = "EXACTLY"; + break; + case NOTHING: + p = "NOTHING"; + break; + case BACK: + p = "BACK"; + break; + case END: + p = "END"; + break; + case OPEN+1: + case OPEN+2: + case OPEN+3: + case OPEN+4: + case OPEN+5: + case OPEN+6: + case OPEN+7: + case OPEN+8: + case OPEN+9: + sprintf(buf+strlen(buf), "OPEN%d", OP(op)-OPEN); + p = NULL; + break; + case CLOSE+1: + case CLOSE+2: + case CLOSE+3: + case CLOSE+4: + case CLOSE+5: + case CLOSE+6: + case CLOSE+7: + case CLOSE+8: + case CLOSE+9: + sprintf(buf+strlen(buf), "CLOSE%d", OP(op)-CLOSE); + p = NULL; + break; + case STAR: + p = "STAR"; + break; + case PLUS: + p = "PLUS"; + break; + default: + TclRegError("corrupted opcode"); + break; + } + if (p != NULL) + (void) strcat(buf, p); + return(buf); +} +#endif + +/* + * The following is provided for those people who do not have strcspn() in + * their C libraries. They should get off their butts and do something + * about it; at least one public-domain implementation of those (highly + * useful) string routines has been published on Usenet. + */ +#ifdef STRCSPN +/* + * strcspn - find length of initial segment of s1 consisting entirely + * of characters not from s2 + */ + +static int +strcspn(s1, s2) +char *s1; +char *s2; +{ + register char *scan1; + register char *scan2; + register int count; + + count = 0; + for (scan1 = s1; *scan1 != '\0'; scan1++) { + for (scan2 = s2; *scan2 != '\0';) /* ++ moved down. */ + if (*scan1 == *scan2++) + return(count); + count++; + } + return(count); +} +#endif diff --git a/vendor/x11iraf/obm/Tcl/tcl.h b/vendor/x11iraf/obm/Tcl/tcl.h new file mode 100644 index 00000000..5c9288aa --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/tcl.h @@ -0,0 +1,649 @@ +/* + * tcl.h -- + * + * This header file describes the externally-visible facilities + * of the Tcl interpreter. + * + * Copyright (c) 1987-1993 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. + * + * $Header: /user6/ouster/tcl/RCS/tcl.h,v 1.131 93/11/21 14:50:35 ouster Exp $ SPRITE (Berkeley) + */ + +#ifndef _TCL +#define _TCL + +#ifndef BUFSIZ +#include <stdio.h> +#endif + +#define TCL_VERSION "7.3" +#define TCL_MAJOR_VERSION 7 +#define TCL_MINOR_VERSION 3 + +/* + * Definitions that allow this header file to be used either with or + * without ANSI C features like function prototypes. + */ + +#undef _ANSI_ARGS_ +#undef CONST +#if ((defined(__STDC__) || defined(SABER)) && !defined(NO_PROTOTYPE)) || defined(__cplusplus) +# define _USING_PROTOTYPES_ 1 +# define _ANSI_ARGS_(x) x +# define CONST const +# ifdef __cplusplus +# define VARARGS (...) +# else +# define VARARGS () +# endif +#else +# define _ANSI_ARGS_(x) () +# define CONST +#endif + +#ifdef __cplusplus +# define EXTERN extern "C" +#else +# define EXTERN extern +#endif + +/* + * Macro to use instead of "void" for arguments that must have + * type "void *" in ANSI C; maps them to type "char *" in + * non-ANSI systems. + */ + +#ifndef VOID +# ifdef __STDC__ +# define VOID void +# else +# define VOID char +# endif +#endif + +/* + * Miscellaneous declarations (to allow Tcl to be used stand-alone, + * without the rest of Sprite). + */ + +#ifndef NULL +#define NULL 0 +#endif + +#ifndef _CLIENTDATA +# ifdef __STDC__ + typedef void *ClientData; +# else + typedef int *ClientData; +# endif /* __STDC__ */ +#define _CLIENTDATA +#endif + +/* + * Data structures defined opaquely in this module. The definitions + * below just provide dummy types. A few fields are made visible in + * Tcl_Interp structures, namely those for returning string values. + * Note: any change to the Tcl_Interp definition below must be mirrored + * in the "real" definition in tclInt.h. + */ + +typedef struct Tcl_Interp{ + char *result; /* Points to result string returned by last + * command. */ + void (*freeProc) _ANSI_ARGS_((char *blockPtr)); + /* Zero means result is statically allocated. + * If non-zero, gives address of procedure + * to invoke to free the result. Must be + * freed by Tcl_Eval before executing next + * command. */ + int errorLine; /* When TCL_ERROR is returned, this gives + * the line number within the command where + * the error occurred (1 means first line). */ +} Tcl_Interp; + +typedef int *Tcl_Trace; +typedef struct Tcl_AsyncHandler_ *Tcl_AsyncHandler; + +/* + * When a TCL command returns, the string pointer interp->result points to + * a string containing return information from the command. In addition, + * the command procedure returns an integer value, which is one of the + * following: + * + * TCL_OK Command completed normally; interp->result contains + * the command's result. + * TCL_ERROR The command couldn't be completed successfully; + * interp->result describes what went wrong. + * TCL_RETURN The command requests that the current procedure + * return; interp->result contains the procedure's + * return value. + * TCL_BREAK The command requests that the innermost loop + * be exited; interp->result is meaningless. + * TCL_CONTINUE Go on to the next iteration of the current loop; + * interp->result is meaningless. + */ + +#define TCL_OK 0 +#define TCL_ERROR 1 +#define TCL_RETURN 2 +#define TCL_BREAK 3 +#define TCL_CONTINUE 4 + +#define TCL_RESULT_SIZE 200 + +/* + * Argument descriptors for math function callbacks in expressions: + */ + +typedef enum {TCL_INT, TCL_DOUBLE, TCL_EITHER} Tcl_ValueType; +typedef struct Tcl_Value { + Tcl_ValueType type; /* Indicates intValue or doubleValue is + * valid, or both. */ + int intValue; /* Integer value. */ + double doubleValue; /* Double-precision floating value. */ +} Tcl_Value; + +/* + * Procedure types defined by Tcl: + */ + +typedef int (Tcl_AsyncProc) _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int code)); +typedef void (Tcl_CmdDeleteProc) _ANSI_ARGS_((ClientData clientData)); +typedef int (Tcl_CmdProc) _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char *argv[])); +typedef void (Tcl_CmdTraceProc) _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int level, char *command, Tcl_CmdProc *proc, + ClientData cmdClientData, int argc, char *argv[])); +typedef void (Tcl_FreeProc) _ANSI_ARGS_((char *blockPtr)); +typedef void (Tcl_InterpDeleteProc) _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp)); +typedef int (Tcl_MathProc) _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, Tcl_Value *args, Tcl_Value *resultPtr)); +typedef char *(Tcl_VarTraceProc) _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, char *part1, char *part2, int flags)); + +/* + * The structure returned by Tcl_GetCmdInfo and passed into + * Tcl_SetCmdInfo: + */ + +typedef struct Tcl_CmdInfo { + Tcl_CmdProc *proc; /* Procedure that implements command. */ + ClientData clientData; /* ClientData passed to proc. */ + Tcl_CmdDeleteProc *deleteProc; /* Procedure to call when command + * is deleted. */ + ClientData deleteData; /* Value to pass to deleteProc (usually + * the same as clientData). */ +} Tcl_CmdInfo; + +/* + * The structure defined below is used to hold dynamic strings. The only + * field that clients should use is the string field, and they should + * never modify it. + */ + +#define TCL_DSTRING_STATIC_SIZE 200 +typedef struct Tcl_DString { + char *string; /* Points to beginning of string: either + * staticSpace below or a malloc'ed array. */ + int length; /* Number of non-NULL characters in the + * string. */ + int spaceAvl; /* Total number of bytes available for the + * string and its terminating NULL char. */ + char staticSpace[TCL_DSTRING_STATIC_SIZE]; + /* Space to use in common case where string + * is small. */ +} Tcl_DString; + +#define Tcl_DStringLength(dsPtr) ((dsPtr)->length) +#define Tcl_DStringValue(dsPtr) ((dsPtr)->string) + +/* + * Definitions for the maximum number of digits of precision that may + * be specified in the "tcl_precision" variable, and the number of + * characters of buffer space required by Tcl_PrintDouble. + */ + +#define TCL_MAX_PREC 17 +#define TCL_DOUBLE_SPACE (TCL_MAX_PREC+10) + +/* + * Flag values passed to Tcl_Eval (see the man page for details; also + * see tclInt.h for additional flags that are only used internally by + * Tcl): + */ + +#define TCL_BRACKET_TERM 1 + +/* + * Flag that may be passed to Tcl_ConvertElement to force it not to + * output braces (careful! if you change this flag be sure to change + * the definitions at the front of tclUtil.c). + */ + +#define TCL_DONT_USE_BRACES 1 + +/* + * Flag value passed to Tcl_RecordAndEval to request no evaluation + * (record only). + */ + +#define TCL_NO_EVAL -1 + +/* + * Special freeProc values that may be passed to Tcl_SetResult (see + * the man page for details): + */ + +#define TCL_VOLATILE ((Tcl_FreeProc *) -1) +#define TCL_STATIC ((Tcl_FreeProc *) 0) +#define TCL_DYNAMIC ((Tcl_FreeProc *) free) + +/* + * Flag values passed to variable-related procedures. + */ + +#define TCL_GLOBAL_ONLY 1 +#define TCL_APPEND_VALUE 2 +#define TCL_LIST_ELEMENT 4 +#define TCL_TRACE_READS 0x10 +#define TCL_TRACE_WRITES 0x20 +#define TCL_TRACE_UNSETS 0x40 +#define TCL_TRACE_DESTROYED 0x80 +#define TCL_INTERP_DESTROYED 0x100 +#define TCL_LEAVE_ERR_MSG 0x200 + +/* + * Types for linked variables: + */ + +#define TCL_LINK_INT 1 +#define TCL_LINK_DOUBLE 2 +#define TCL_LINK_BOOLEAN 3 +#define TCL_LINK_STRING 4 +#define TCL_LINK_READ_ONLY 0x80 + +/* + * Permission flags for files: + */ + +#define TCL_FILE_READABLE 1 +#define TCL_FILE_WRITABLE 2 + +/* + * The following declarations either map ckalloc and ckfree to + * malloc and free, or they map them to procedures with all sorts + * of debugging hooks defined in tclCkalloc.c. + */ + +#ifdef TCL_MEM_DEBUG + +EXTERN char * Tcl_DbCkalloc _ANSI_ARGS_((unsigned int size, + char *file, int line)); +EXTERN int Tcl_DbCkfree _ANSI_ARGS_((char *ptr, + char *file, int line)); +EXTERN char * Tcl_DbCkrealloc _ANSI_ARGS_((char *ptr, + unsigned int size, char *file, int line)); +EXTERN int Tcl_DumpActiveMemory _ANSI_ARGS_((char *fileName)); +EXTERN void Tcl_ValidateAllMemory _ANSI_ARGS_((char *file, + int line)); +# define ckalloc(x) Tcl_DbCkalloc(x, __FILE__, __LINE__) +# define ckfree(x) Tcl_DbCkfree(x, __FILE__, __LINE__) +# define ckrealloc(x,y) Tcl_DbCkrealloc((x), (y),__FILE__, __LINE__) + +#else + +# define ckalloc(x) malloc(x) +# define ckfree(x) free(x) +# define ckrealloc(x,y) realloc(x,y) +# define Tcl_DumpActiveMemory(x) +# define Tcl_ValidateAllMemory(x,y) + +#endif /* TCL_MEM_DEBUG */ + +/* + * Macro to free up result of interpreter. + */ + +#define Tcl_FreeResult(interp) \ + if ((interp)->freeProc != 0) { \ + if ((interp)->freeProc == (Tcl_FreeProc *) free) { \ + ckfree((interp)->result); \ + } else { \ + (*(interp)->freeProc)((interp)->result); \ + } \ + (interp)->freeProc = 0; \ + } + +/* + * Forward declaration of Tcl_HashTable. Needed by some C++ compilers + * to prevent errors when the forward reference to Tcl_HashTable is + * encountered in the Tcl_HashEntry structure. + */ + +#ifdef __cplusplus +struct Tcl_HashTable; +#endif + +/* + * Structure definition for an entry in a hash table. No-one outside + * Tcl should access any of these fields directly; use the macros + * defined below. + */ + +typedef struct Tcl_HashEntry { + struct Tcl_HashEntry *nextPtr; /* Pointer to next entry in this + * hash bucket, or NULL for end of + * chain. */ + struct Tcl_HashTable *tablePtr; /* Pointer to table containing entry. */ + struct Tcl_HashEntry **bucketPtr; /* Pointer to bucket that points to + * first entry in this entry's chain: + * used for deleting the entry. */ + ClientData clientData; /* Application stores something here + * with Tcl_SetHashValue. */ + union { /* Key has one of these forms: */ + char *oneWordValue; /* One-word value for key. */ + int words[1]; /* Multiple integer words for key. + * The actual size will be as large + * as necessary for this table's + * keys. */ + char string[4]; /* String for key. The actual size + * will be as large as needed to hold + * the key. */ + } key; /* MUST BE LAST FIELD IN RECORD!! */ +} Tcl_HashEntry; + +/* + * Structure definition for a hash table. Must be in tcl.h so clients + * can allocate space for these structures, but clients should never + * access any fields in this structure. + */ + +#define TCL_SMALL_HASH_TABLE 4 +typedef struct Tcl_HashTable { + Tcl_HashEntry **buckets; /* Pointer to bucket array. Each + * element points to first entry in + * bucket's hash chain, or NULL. */ + Tcl_HashEntry *staticBuckets[TCL_SMALL_HASH_TABLE]; + /* Bucket array used for small tables + * (to avoid mallocs and frees). */ + int numBuckets; /* Total number of buckets allocated + * at **bucketPtr. */ + int numEntries; /* Total number of entries present + * in table. */ + int rebuildSize; /* Enlarge table when numEntries gets + * to be this large. */ + int downShift; /* Shift count used in hashing + * function. Designed to use high- + * order bits of randomized keys. */ + int mask; /* Mask value used in hashing + * function. */ + int keyType; /* Type of keys used in this table. + * It's either TCL_STRING_KEYS, + * TCL_ONE_WORD_KEYS, or an integer + * giving the number of ints in a + */ + Tcl_HashEntry *(*findProc) _ANSI_ARGS_((struct Tcl_HashTable *tablePtr, + char *key)); + Tcl_HashEntry *(*createProc) _ANSI_ARGS_((struct Tcl_HashTable *tablePtr, + char *key, int *newPtr)); +} Tcl_HashTable; + +/* + * Structure definition for information used to keep track of searches + * through hash tables: + */ + +typedef struct Tcl_HashSearch { + Tcl_HashTable *tablePtr; /* Table being searched. */ + int nextIndex; /* Index of next bucket to be + * enumerated after present one. */ + Tcl_HashEntry *nextEntryPtr; /* Next entry to be enumerated in the + * the current bucket. */ +} Tcl_HashSearch; + +/* + * Acceptable key types for hash tables: + */ + +#define TCL_STRING_KEYS 0 +#define TCL_ONE_WORD_KEYS 1 + +/* + * Macros for clients to use to access fields of hash entries: + */ + +#define Tcl_GetHashValue(h) ((h)->clientData) +#define Tcl_SetHashValue(h, value) ((h)->clientData = (ClientData) (value)) +#define Tcl_GetHashKey(tablePtr, h) \ + ((char *) (((tablePtr)->keyType == TCL_ONE_WORD_KEYS) ? (h)->key.oneWordValue \ + : (h)->key.string)) + +/* + * Macros to use for clients to use to invoke find and create procedures + * for hash tables: + */ + +#define Tcl_FindHashEntry(tablePtr, key) \ + (*((tablePtr)->findProc))(tablePtr, key) +#define Tcl_CreateHashEntry(tablePtr, key, newPtr) \ + (*((tablePtr)->createProc))(tablePtr, key, newPtr) + +/* + * Exported Tcl variables: + */ + +EXTERN int tcl_AsyncReady; +EXTERN char * tcl_RcFileName; + +/* + * Exported Tcl procedures: + */ + +EXTERN void Tcl_AsyncMark _ANSI_ARGS_((Tcl_AsyncHandler async)); +EXTERN Tcl_AsyncHandler Tcl_AsyncCreate _ANSI_ARGS_((Tcl_AsyncProc *proc, + ClientData clientData)); +EXTERN void Tcl_AsyncDelete _ANSI_ARGS_((Tcl_AsyncHandler async)); +EXTERN int Tcl_AsyncInvoke _ANSI_ARGS_((Tcl_Interp *interp, + int code)); +EXTERN void Tcl_AppendElement _ANSI_ARGS_((Tcl_Interp *interp, + char *string)); +#ifdef ELLIPSES +#ifdef USE_STDARG +EXTERN void Tcl_AppendResult _ANSI_ARGS_((Tcl_Interp *interp, ...)); +#else +EXTERN void Tcl_AppendResult _ANSI_ARGS_(VARARGS); +#endif +#endif +EXTERN int Tcl_AppInit _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN void Tcl_AddErrorInfo _ANSI_ARGS_((Tcl_Interp *interp, + char *message)); +EXTERN char Tcl_Backslash _ANSI_ARGS_((char *src, + int *readPtr)); +EXTERN void Tcl_CallWhenDeleted _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_InterpDeleteProc *proc, + ClientData clientData)); +EXTERN int Tcl_CommandComplete _ANSI_ARGS_((char *cmd)); +EXTERN char * Tcl_Concat _ANSI_ARGS_((int argc, char **argv)); +EXTERN int Tcl_ConvertElement _ANSI_ARGS_((char *src, + char *dst, int flags)); +EXTERN void Tcl_CreateCommand _ANSI_ARGS_((Tcl_Interp *interp, + char *cmdName, Tcl_CmdProc *proc, + ClientData clientData, + Tcl_CmdDeleteProc *deleteProc)); +EXTERN Tcl_Interp * Tcl_CreateInterp _ANSI_ARGS_((void)); +EXTERN void Tcl_CreateMathFunc _ANSI_ARGS_((Tcl_Interp *interp, + char *name, int numArgs, Tcl_ValueType *argTypes, + Tcl_MathProc *proc, ClientData clientData)); +EXTERN int Tcl_CreatePipeline _ANSI_ARGS_((Tcl_Interp *interp, + int argc, char **argv, int **pidArrayPtr, + int *inPipePtr, int *outPipePtr, + int *errFilePtr)); +EXTERN Tcl_Trace Tcl_CreateTrace _ANSI_ARGS_((Tcl_Interp *interp, + int level, Tcl_CmdTraceProc *proc, + ClientData clientData)); +EXTERN void Tcl_DeleteHashEntry _ANSI_ARGS_(( + Tcl_HashEntry *entryPtr)); +EXTERN void Tcl_DeleteHashTable _ANSI_ARGS_(( + Tcl_HashTable *tablePtr)); +EXTERN char * Tcl_DStringAppend _ANSI_ARGS_((Tcl_DString *dsPtr, + char *string, int length)); +EXTERN char * Tcl_DStringAppendElement _ANSI_ARGS_(( + Tcl_DString *dsPtr, char *string)); +EXTERN void Tcl_DStringEndSublist _ANSI_ARGS_((Tcl_DString *dsPtr)); +EXTERN void Tcl_DStringFree _ANSI_ARGS_((Tcl_DString *dsPtr)); +EXTERN void Tcl_DStringInit _ANSI_ARGS_((Tcl_DString *dsPtr)); +EXTERN void Tcl_DStringResult _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_DString *dsPtr)); +EXTERN void Tcl_DStringStartSublist _ANSI_ARGS_(( + Tcl_DString *dsPtr)); +EXTERN void Tcl_DStringTrunc _ANSI_ARGS_((Tcl_DString *dsPtr, + int length)); +EXTERN int Tcl_DeleteCommand _ANSI_ARGS_((Tcl_Interp *interp, + char *cmdName)); +EXTERN void Tcl_DeleteInterp _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN void Tcl_DeleteTrace _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Trace trace)); +EXTERN void Tcl_DetachPids _ANSI_ARGS_((int numPids, int *pidPtr)); +EXTERN void Tcl_DontCallWhenDeleted _ANSI_ARGS_(( + Tcl_Interp *interp, Tcl_InterpDeleteProc *proc, + ClientData clientData)); +EXTERN void Tcl_EnterFile _ANSI_ARGS_((Tcl_Interp *interp, + FILE *file, int permissions)); +EXTERN char * Tcl_ErrnoId _ANSI_ARGS_((void)); +EXTERN int Tcl_Eval _ANSI_ARGS_((Tcl_Interp *interp, char *cmd)); +EXTERN int Tcl_EvalFile _ANSI_ARGS_((Tcl_Interp *interp, + char *fileName)); +EXTERN int Tcl_ExprBoolean _ANSI_ARGS_((Tcl_Interp *interp, + char *string, int *ptr)); +EXTERN int Tcl_ExprDouble _ANSI_ARGS_((Tcl_Interp *interp, + char *string, double *ptr)); +EXTERN int Tcl_ExprLong _ANSI_ARGS_((Tcl_Interp *interp, + char *string, long *ptr)); +EXTERN int Tcl_ExprString _ANSI_ARGS_((Tcl_Interp *interp, + char *string)); +EXTERN int Tcl_FilePermissions _ANSI_ARGS_((FILE *file)); +EXTERN Tcl_HashEntry * Tcl_FirstHashEntry _ANSI_ARGS_(( + Tcl_HashTable *tablePtr, + Tcl_HashSearch *searchPtr)); +EXTERN int Tcl_GetBoolean _ANSI_ARGS_((Tcl_Interp *interp, + char *string, int *boolPtr)); +EXTERN int Tcl_GetCommandInfo _ANSI_ARGS_((Tcl_Interp *interp, + char *cmdName, Tcl_CmdInfo *infoPtr)); +EXTERN int Tcl_GetDouble _ANSI_ARGS_((Tcl_Interp *interp, + char *string, double *doublePtr)); +EXTERN int Tcl_GetInt _ANSI_ARGS_((Tcl_Interp *interp, + char *string, int *intPtr)); +EXTERN int Tcl_GetOpenFile _ANSI_ARGS_((Tcl_Interp *interp, + char *string, int write, int checkUsage, + FILE **filePtr)); +EXTERN char * Tcl_GetVar _ANSI_ARGS_((Tcl_Interp *interp, + char *varName, int flags)); +EXTERN char * Tcl_GetVar2 _ANSI_ARGS_((Tcl_Interp *interp, + char *part1, char *part2, int flags)); +EXTERN int Tcl_GlobalEval _ANSI_ARGS_((Tcl_Interp *interp, + char *command)); +EXTERN char * Tcl_HashStats _ANSI_ARGS_((Tcl_HashTable *tablePtr)); +EXTERN int Tcl_Init _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN void Tcl_InitHashTable _ANSI_ARGS_((Tcl_HashTable *tablePtr, + int keyType)); +EXTERN void Tcl_InitMemory _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN int Tcl_LinkVar _ANSI_ARGS_((Tcl_Interp *interp, + char *varName, char *addr, int type)); +EXTERN char * Tcl_Merge _ANSI_ARGS_((int argc, char **argv)); +EXTERN Tcl_HashEntry * Tcl_NextHashEntry _ANSI_ARGS_(( + Tcl_HashSearch *searchPtr)); +EXTERN char * Tcl_ParseVar _ANSI_ARGS_((Tcl_Interp *interp, + char *string, char **termPtr)); +EXTERN char * Tcl_PosixError _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN void Tcl_PrintDouble _ANSI_ARGS_((Tcl_Interp *interp, + double value, char *dst)); +EXTERN void Tcl_ReapDetachedProcs _ANSI_ARGS_((void)); +EXTERN int Tcl_RecordAndEval _ANSI_ARGS_((Tcl_Interp *interp, + char *cmd, int flags)); +EXTERN int Tcl_RegExpMatch _ANSI_ARGS_((Tcl_Interp *interp, + char *string, char *pattern)); +EXTERN void Tcl_ResetResult _ANSI_ARGS_((Tcl_Interp *interp)); +#define Tcl_Return Tcl_SetResult +EXTERN int Tcl_ScanElement _ANSI_ARGS_((char *string, + int *flagPtr)); +EXTERN int Tcl_SetCommandInfo _ANSI_ARGS_((Tcl_Interp *interp, + char *cmdName, Tcl_CmdInfo *infoPtr)); +#ifdef ELLIPSES +#ifdef USE_STDARG +EXTERN void Tcl_SetErrorCode _ANSI_ARGS_((Tcl_Interp *interp, ...)); +#else +EXTERN void Tcl_SetErrorCode _ANSI_ARGS_(VARARGS); +#endif +#endif +EXTERN int Tcl_SetRecursionLimit _ANSI_ARGS_((Tcl_Interp *interp, + int depth)); +EXTERN void Tcl_SetResult _ANSI_ARGS_((Tcl_Interp *interp, + char *string, Tcl_FreeProc *freeProc)); +EXTERN char * Tcl_SetVar _ANSI_ARGS_((Tcl_Interp *interp, + char *varName, char *newValue, int flags)); +EXTERN char * Tcl_SetVar2 _ANSI_ARGS_((Tcl_Interp *interp, + char *part1, char *part2, char *newValue, + int flags)); +EXTERN char * Tcl_SignalId _ANSI_ARGS_((int sig)); +EXTERN char * Tcl_SignalMsg _ANSI_ARGS_((int sig)); +EXTERN int Tcl_SplitList _ANSI_ARGS_((Tcl_Interp *interp, + char *list, int *argcPtr, char ***argvPtr)); +EXTERN int Tcl_StringMatch _ANSI_ARGS_((char *string, + char *pattern)); +EXTERN char * Tcl_TildeSubst _ANSI_ARGS_((Tcl_Interp *interp, + char *name, Tcl_DString *bufferPtr)); +EXTERN int Tcl_TraceVar _ANSI_ARGS_((Tcl_Interp *interp, + char *varName, int flags, Tcl_VarTraceProc *proc, + ClientData clientData)); +EXTERN int Tcl_TraceVar2 _ANSI_ARGS_((Tcl_Interp *interp, + char *part1, char *part2, int flags, + Tcl_VarTraceProc *proc, ClientData clientData)); +EXTERN void Tcl_UnlinkVar _ANSI_ARGS_((Tcl_Interp *interp, + char *varName)); +EXTERN int Tcl_UnsetVar _ANSI_ARGS_((Tcl_Interp *interp, + char *varName, int flags)); +EXTERN int Tcl_UnsetVar2 _ANSI_ARGS_((Tcl_Interp *interp, + char *part1, char *part2, int flags)); +EXTERN void Tcl_UntraceVar _ANSI_ARGS_((Tcl_Interp *interp, + char *varName, int flags, Tcl_VarTraceProc *proc, + ClientData clientData)); +EXTERN void Tcl_UntraceVar2 _ANSI_ARGS_((Tcl_Interp *interp, + char *part1, char *part2, int flags, + Tcl_VarTraceProc *proc, ClientData clientData)); +#ifdef ELLIPSES +#ifdef USE_STDARG +EXTERN int Tcl_VarEval _ANSI_ARGS_((Tcl_Interp *iPtr, ...)); +#else +EXTERN int Tcl_VarEval _ANSI_ARGS_(VARARGS); +#endif +#endif +EXTERN ClientData Tcl_VarTraceInfo _ANSI_ARGS_((Tcl_Interp *interp, + char *varName, int flags, + Tcl_VarTraceProc *procPtr, + ClientData prevClientData)); +EXTERN ClientData Tcl_VarTraceInfo2 _ANSI_ARGS_((Tcl_Interp *interp, + char *part1, char *part2, int flags, + Tcl_VarTraceProc *procPtr, + ClientData prevClientData)); + +#endif /* _TCL */ diff --git a/vendor/x11iraf/obm/Tcl/tclAppInit.c b/vendor/x11iraf/obm/Tcl/tclAppInit.c new file mode 100644 index 00000000..df7f93c1 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/tclAppInit.c @@ -0,0 +1,95 @@ +/* + * tclAppInit.c -- + * + * Provides a default version of the Tcl_AppInit procedure. + * + * Copyright (c) 1993 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. + */ + +#ifndef lint +static char rcsid[] = "$Header: /user6/ouster/tcl/RCS/tclAppInit.c,v 1.6 93/08/26 14:34:55 ouster Exp $ SPRITE (Berkeley)"; +#endif /* not lint */ + +#include "tcl.h" + +/* + * The following variable is a special hack that allows applications + * to be linked using the procedure "main" from the Tcl library. The + * variable generates a reference to "main", which causes main to + * be brought in from the library (and all of Tcl with it). + */ + +extern int main(); +int *tclDummyMainPtr = (int *) main; + +/* + *---------------------------------------------------------------------- + * + * Tcl_AppInit -- + * + * This procedure performs application-specific initialization. + * Most applications, especially those that incorporate additional + * packages, will have their own version of this procedure. + * + * Results: + * Returns a standard Tcl completion code, and leaves an error + * message in interp->result if an error occurs. + * + * Side effects: + * Depends on the startup script. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_AppInit(interp) + Tcl_Interp *interp; /* Interpreter for application. */ +{ + /* + * Call the init procedures for included packages. Each call should + * look like this: + * + * if (Mod_Init(interp) == TCL_ERROR) { + * return TCL_ERROR; + * } + * + * where "Mod" is the name of the module. + */ + + if (Tcl_Init(interp) == TCL_ERROR) { + return TCL_ERROR; + } + + /* + * 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_RcFileName = "~/.tclshrc"; + return TCL_OK; +} diff --git a/vendor/x11iraf/obm/Tcl/tclAsync.c b/vendor/x11iraf/obm/Tcl/tclAsync.c new file mode 100644 index 00000000..447f5d4c --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/tclAsync.c @@ -0,0 +1,256 @@ +/* + * tclAsync.c -- + * + * This file provides low-level support needed to invoke signal + * handlers in a safe way. The code here doesn't actually handle + * signals, though. This code is based on proposals made by + * Mark Diekhans and Don Libes. + * + * Copyright (c) 1993 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. + */ + +#ifndef lint +static char rcsid[] = "$Header: /user6/ouster/tcl/RCS/tclAsync.c,v 1.3 93/09/02 16:02:42 ouster Exp $ SPRITE (Berkeley)"; +#endif /* not lint */ + +#include "tclInt.h" + +/* + * One of the following structures exists for each asynchronous + * handler: + */ + +typedef struct AsyncHandler { + int ready; /* Non-zero means this handler should + * be invoked in the next call to + * Tcl_AsyncInvoke. */ + struct AsyncHandler *nextPtr; /* Next in list of all handlers for + * the process. */ + Tcl_AsyncProc *proc; /* Procedure to call when handler + * is invoked. */ + ClientData clientData; /* Value to pass to handler when it + * is invoked. */ +} AsyncHandler; + +/* + * The variables below maintain a list of all existing handlers. + */ + +static AsyncHandler *firstHandler; /* First handler defined for process, + * or NULL if none. */ +static AsyncHandler *lastHandler; /* Last handler or NULL. */ + +/* + * The variable below is set to 1 whenever a handler becomes ready and + * it is cleared to zero whenever Tcl_AsyncInvoke is called. It can be + * checked elsewhere in the application to see if Tcl_AsyncInvoke + * should be invoked. + */ + +int tcl_AsyncReady = 0; + +/* + * The variable below indicates whether Tcl_AsyncInvoke is currently + * working. If so then we won't set tcl_AsyncReady again until + * Tcl_AsyncInvoke returns. + */ + +static int asyncActive = 0; + +/* + *---------------------------------------------------------------------- + * + * Tcl_AsyncCreate -- + * + * This procedure creates the data structures for an asynchronous + * handler, so that no memory has to be allocated when the handler + * is activated. + * + * Results: + * The return value is a token for the handler, which can be used + * to activate it later on. + * + * Side effects: + * Information about the handler is recorded. + * + *---------------------------------------------------------------------- + */ + +Tcl_AsyncHandler +Tcl_AsyncCreate(proc, clientData) + Tcl_AsyncProc *proc; /* Procedure to call when handler + * is invoked. */ + ClientData clientData; /* Argument to pass to handler. */ +{ + AsyncHandler *asyncPtr; + + asyncPtr = (AsyncHandler *) ckalloc(sizeof(AsyncHandler)); + asyncPtr->ready = 0; + asyncPtr->nextPtr = NULL; + asyncPtr->proc = proc; + asyncPtr->clientData = clientData; + if (firstHandler == NULL) { + firstHandler = asyncPtr; + } else { + lastHandler->nextPtr = asyncPtr; + } + lastHandler = asyncPtr; + return (Tcl_AsyncHandler) asyncPtr; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_AsyncMark -- + * + * This procedure is called to request that an asynchronous handler + * be invoked as soon as possible. It's typically called from + * an interrupt handler, where it isn't safe to do anything that + * depends on or modifies application state. + * + * Results: + * None. + * + * Side effects: + * The handler gets marked for invocation later. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_AsyncMark(async) + Tcl_AsyncHandler async; /* Token for handler. */ +{ + ((AsyncHandler *) async)->ready = 1; + if (!asyncActive) { + tcl_AsyncReady = 1; + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_AsyncInvoke -- + * + * This procedure is called at a "safe" time at background level + * to invoke any active asynchronous handlers. + * + * Results: + * The return value is a normal Tcl result, which is intended to + * replace the code argument as the current completion code for + * interp. + * + * Side effects: + * Depends on the handlers that are active. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_AsyncInvoke(interp, code) + Tcl_Interp *interp; /* If invoked from Tcl_Eval just after + * completing a command, points to + * interpreter. Otherwise it is + * NULL. */ + int code; /* If interp is non-NULL, this gives + * completion code from command that + * just completed. */ +{ + AsyncHandler *asyncPtr; + + if (tcl_AsyncReady == 0) { + return code; + } + tcl_AsyncReady = 0; + asyncActive = 1; + if (interp == NULL) { + code = 0; + } + + /* + * Make one or more passes over the list of handlers, invoking + * at most one handler in each pass. After invoking a handler, + * go back to the start of the list again so that (a) if a new + * higher-priority handler gets marked while executing a lower + * priority handler, we execute the higher-priority handler + * next, and (b) if a handler gets deleted during the execution + * of a handler, then the list structure may change so it isn't + * safe to continue down the list anyway. + */ + + while (1) { + for (asyncPtr = firstHandler; asyncPtr != NULL; + asyncPtr = asyncPtr->nextPtr) { + if (asyncPtr->ready) { + break; + } + } + if (asyncPtr == NULL) { + break; + } + asyncPtr->ready = 0; + code = (*asyncPtr->proc)(asyncPtr->clientData, interp, code); + } + asyncActive = 0; + return code; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_AsyncDelete -- + * + * Frees up all the state for an asynchronous handler. The handler + * should never be used again. + * + * Results: + * None. + * + * Side effects: + * The state associated with the handler is deleted. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_AsyncDelete(async) + Tcl_AsyncHandler async; /* Token for handler to delete. */ +{ + AsyncHandler *asyncPtr = (AsyncHandler *) async; + AsyncHandler *prevPtr; + + if (firstHandler == asyncPtr) { + firstHandler = asyncPtr->nextPtr; + if (firstHandler == NULL) { + lastHandler = NULL; + } + } else { + prevPtr = firstHandler; + while (prevPtr->nextPtr != asyncPtr) { + prevPtr = prevPtr->nextPtr; + } + prevPtr->nextPtr = asyncPtr->nextPtr; + if (lastHandler == asyncPtr) { + lastHandler = prevPtr; + } + } + ckfree((char *) asyncPtr); +} diff --git a/vendor/x11iraf/obm/Tcl/tclBasic.c b/vendor/x11iraf/obm/Tcl/tclBasic.c new file mode 100644 index 00000000..be5469db --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/tclBasic.c @@ -0,0 +1,1381 @@ +/* + * tclBasic.c -- + * + * Contains the basic facilities for TCL command interpretation, + * including interpreter creation and deletion, command creation + * and deletion, and command parsing and execution. + * + * Copyright (c) 1987-1993 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. + */ + +#ifndef lint +static char rcsid[] = "$Header: /user6/ouster/tcl/RCS/tclBasic.c,v 1.153 93/09/09 16:43:19 ouster Exp $ SPRITE (Berkeley)"; +#endif + +#include "tclInt.h" +#ifndef TCL_GENERIC_ONLY +# include "tclUnix.h" +#endif + +/* + * The following structure defines all of the commands in the Tcl core, + * and the C procedures that execute them. + */ + +typedef struct { + char *name; /* Name of command. */ + Tcl_CmdProc *proc; /* Procedure that executes command. */ +} CmdInfo; + +/* + * Built-in commands, and the procedures associated with them: + */ + +static CmdInfo builtInCmds[] = { + /* + * Commands in the generic core: + */ + + {"append", Tcl_AppendCmd}, + {"array", Tcl_ArrayCmd}, + {"break", Tcl_BreakCmd}, + {"case", Tcl_CaseCmd}, + {"catch", Tcl_CatchCmd}, + {"concat", Tcl_ConcatCmd}, + {"continue", Tcl_ContinueCmd}, + {"error", Tcl_ErrorCmd}, + {"eval", Tcl_EvalCmd}, + {"expr", Tcl_ExprCmd}, + {"for", Tcl_ForCmd}, + {"foreach", Tcl_ForeachCmd}, + {"format", Tcl_FormatCmd}, + {"global", Tcl_GlobalCmd}, + {"history", Tcl_HistoryCmd}, + {"if", Tcl_IfCmd}, + {"incr", Tcl_IncrCmd}, + {"info", Tcl_InfoCmd}, + {"join", Tcl_JoinCmd}, + {"lappend", Tcl_LappendCmd}, + {"lindex", Tcl_LindexCmd}, + {"linsert", Tcl_LinsertCmd}, + {"list", Tcl_ListCmd}, + {"llength", Tcl_LlengthCmd}, + {"lrange", Tcl_LrangeCmd}, + {"lreplace", Tcl_LreplaceCmd}, + {"lsearch", Tcl_LsearchCmd}, + {"lsort", Tcl_LsortCmd}, + {"proc", Tcl_ProcCmd}, + {"regexp", Tcl_RegexpCmd}, + {"regsub", Tcl_RegsubCmd}, + {"rename", Tcl_RenameCmd}, + {"return", Tcl_ReturnCmd}, + {"scan", Tcl_ScanCmd}, + {"set", Tcl_SetCmd}, + {"split", Tcl_SplitCmd}, + {"string", Tcl_StringCmd}, + {"switch", Tcl_SwitchCmd}, + {"trace", Tcl_TraceCmd}, + {"unset", Tcl_UnsetCmd}, + {"uplevel", Tcl_UplevelCmd}, + {"upvar", Tcl_UpvarCmd}, + {"while", Tcl_WhileCmd}, + + /* + * Commands in the UNIX core: + */ + +#ifndef TCL_GENERIC_ONLY + {"cd", Tcl_CdCmd}, + {"close", Tcl_CloseCmd}, + {"eof", Tcl_EofCmd}, + {"exec", Tcl_ExecCmd}, + {"exit", Tcl_ExitCmd}, + {"file", Tcl_FileCmd}, + {"flush", Tcl_FlushCmd}, + {"gets", Tcl_GetsCmd}, + {"glob", Tcl_GlobCmd}, + {"open", Tcl_OpenCmd}, + {"pid", Tcl_PidCmd}, + {"puts", Tcl_PutsCmd}, + {"pwd", Tcl_PwdCmd}, + {"read", Tcl_ReadCmd}, + {"seek", Tcl_SeekCmd}, + {"source", Tcl_SourceCmd}, + {"tell", Tcl_TellCmd}, + {"time", Tcl_TimeCmd}, +#endif /* TCL_GENERIC_ONLY */ + {NULL, (Tcl_CmdProc *) NULL} +}; + +/* + *---------------------------------------------------------------------- + * + * Tcl_CreateInterp -- + * + * Create a new TCL command interpreter. + * + * Results: + * The return value is a token for the interpreter, which may be + * used in calls to procedures like Tcl_CreateCmd, Tcl_Eval, or + * Tcl_DeleteInterp. + * + * Side effects: + * The command interpreter is initialized with an empty variable + * table and the built-in commands. SIGPIPE signals are set to + * be ignored (see comment below for details). + * + *---------------------------------------------------------------------- + */ + +Tcl_Interp * +Tcl_CreateInterp() +{ + register Interp *iPtr; + register Command *cmdPtr; + register CmdInfo *cmdInfoPtr; + int i; + static int firstInterp = 1; + + iPtr = (Interp *) ckalloc(sizeof(Interp)); + iPtr->result = iPtr->resultSpace; + iPtr->freeProc = 0; + iPtr->errorLine = 0; + Tcl_InitHashTable(&iPtr->commandTable, TCL_STRING_KEYS); + Tcl_InitHashTable(&iPtr->mathFuncTable, TCL_STRING_KEYS); + Tcl_InitHashTable(&iPtr->globalTable, TCL_STRING_KEYS); + iPtr->numLevels = 0; + iPtr->maxNestingDepth = 1000; + iPtr->framePtr = NULL; + iPtr->varFramePtr = NULL; + iPtr->activeTracePtr = NULL; + iPtr->returnCode = TCL_OK; + iPtr->errorInfo = NULL; + iPtr->errorCode = NULL; + iPtr->numEvents = 0; + iPtr->events = NULL; + iPtr->curEvent = 0; + iPtr->curEventNum = 0; + iPtr->revPtr = NULL; + iPtr->historyFirst = NULL; + iPtr->revDisables = 1; + iPtr->evalFirst = iPtr->evalLast = NULL; + iPtr->appendResult = NULL; + iPtr->appendAvl = 0; + iPtr->appendUsed = 0; + for (i = 0; i < NUM_REGEXPS; i++) { + iPtr->patterns[i] = NULL; + iPtr->patLengths[i] = -1; + iPtr->regexps[i] = NULL; + } + strcpy(iPtr->pdFormat, DEFAULT_PD_FORMAT); + iPtr->pdPrec = DEFAULT_PD_PREC; + iPtr->cmdCount = 0; + iPtr->noEval = 0; + iPtr->evalFlags = 0; + iPtr->scriptFile = NULL; + iPtr->flags = 0; + iPtr->tracePtr = NULL; + iPtr->deleteCallbackPtr = NULL; + iPtr->resultSpace[0] = 0; + + /* + * Create the built-in commands. Do it here, rather than calling + * Tcl_CreateCommand, because it's faster (there's no need to + * check for a pre-existing command by the same name). + */ + + for (cmdInfoPtr = builtInCmds; cmdInfoPtr->name != NULL; cmdInfoPtr++) { + int new; + Tcl_HashEntry *hPtr; + + hPtr = Tcl_CreateHashEntry(&iPtr->commandTable, + cmdInfoPtr->name, &new); + if (new) { + cmdPtr = (Command *) ckalloc(sizeof(Command)); + cmdPtr->proc = cmdInfoPtr->proc; + cmdPtr->clientData = (ClientData) NULL; + cmdPtr->deleteProc = NULL; + cmdPtr->deleteData = (ClientData) NULL; + Tcl_SetHashValue(hPtr, cmdPtr); + } + } + +#ifndef TCL_GENERIC_ONLY + TclSetupEnv((Tcl_Interp *) iPtr); + + /* + * The code below causes SIGPIPE (broken pipe) errors to + * be ignored. This is needed so that Tcl processes don't + * die if they create child processes (e.g. using "exec" or + * "open") that terminate prematurely. The signal handler + * is only set up when the first interpreter is created; + * after this the application can override the handler with + * a different one of its own, if it wants. + */ + + if (firstInterp) { + (void) signal(SIGPIPE, SIG_IGN); + firstInterp = 0; + } +#endif + + Tcl_TraceVar2((Tcl_Interp *) iPtr, "tcl_precision", (char *) NULL, + TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + TclPrecTraceProc, (ClientData) NULL); + return (Tcl_Interp *) iPtr; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_Init -- + * + * This procedure is typically invoked by Tcl_AppInit procedures + * to perform additional initialization for a Tcl interpreter, + * such as sourcing the "init.tcl" script. + * + * Results: + * Returns a standard Tcl completion code and sets interp->result + * if there is an error. + * + * Side effects: + * Depends on what's in the init.tcl script. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_Init(interp) + Tcl_Interp *interp; /* Interpreter to initialize. */ +{ + static char initCmd[] = + "if [file exists [info library]/init.tcl] {\n\ + source [info library]/init.tcl\n\ + } else {\n\ + set msg \"can't find [info library]/init.tcl; perhaps you \"\n\ + append msg \"need to\\ninstall Tcl or set your TCL_LIBRARY \"\n\ + append msg \"environment variable?\"\n\ + error $msg\n\ + }"; + + return Tcl_Eval(interp, initCmd); +} + +/* + *-------------------------------------------------------------- + * + * Tcl_CallWhenDeleted -- + * + * Arrange for a procedure to be called before a given + * interpreter is deleted. + * + * Results: + * None. + * + * Side effects: + * When Tcl_DeleteInterp is invoked to delete interp, + * proc will be invoked. See the manual entry for + * details. + * + *-------------------------------------------------------------- + */ + +void +Tcl_CallWhenDeleted(interp, proc, clientData) + Tcl_Interp *interp; /* Interpreter to watch. */ + Tcl_InterpDeleteProc *proc; /* Procedure to call when interpreter + * is about to be deleted. */ + ClientData clientData; /* One-word value to pass to proc. */ +{ + DeleteCallback *dcPtr, *prevPtr; + Interp *iPtr = (Interp *) interp; + + dcPtr = (DeleteCallback *) ckalloc(sizeof(DeleteCallback)); + dcPtr->proc = proc; + dcPtr->clientData = clientData; + dcPtr->nextPtr = NULL; + if (iPtr->deleteCallbackPtr == NULL) { + iPtr->deleteCallbackPtr = dcPtr; + } else { + prevPtr = iPtr->deleteCallbackPtr; + while (prevPtr->nextPtr != NULL) { + prevPtr = prevPtr->nextPtr; + } + prevPtr->nextPtr = dcPtr; + } +} + +/* + *-------------------------------------------------------------- + * + * Tcl_DontCallWhenDeleted -- + * + * Cancel the arrangement for a procedure to be called when + * a given interpreter is deleted. + * + * Results: + * None. + * + * Side effects: + * If proc and clientData were previously registered as a + * callback via Tcl_CallWhenDeleted, they are unregistered. + * If they weren't previously registered then nothing + * happens. + * + *-------------------------------------------------------------- + */ + +void +Tcl_DontCallWhenDeleted(interp, proc, clientData) + Tcl_Interp *interp; /* Interpreter to watch. */ + Tcl_InterpDeleteProc *proc; /* Procedure to call when interpreter + * is about to be deleted. */ + ClientData clientData; /* One-word value to pass to proc. */ +{ + DeleteCallback *prevPtr, *dcPtr; + Interp *iPtr = (Interp *) interp; + + for (prevPtr = NULL, dcPtr = iPtr->deleteCallbackPtr; + dcPtr != NULL; prevPtr = dcPtr, dcPtr = dcPtr->nextPtr) { + if ((dcPtr->proc != proc) || (dcPtr->clientData != clientData)) { + continue; + } + if (prevPtr == NULL) { + iPtr->deleteCallbackPtr = dcPtr->nextPtr; + } else { + prevPtr->nextPtr = dcPtr->nextPtr; + } + ckfree((char *) dcPtr); + break; + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DeleteInterp -- + * + * Delete an interpreter and free up all of the resources associated + * with it. + * + * Results: + * None. + * + * Side effects: + * The interpreter is destroyed. The caller should never again + * use the interp token. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DeleteInterp(interp) + Tcl_Interp *interp; /* Token for command interpreter (returned + * by a previous call to Tcl_CreateInterp). */ +{ + Interp *iPtr = (Interp *) interp; + Tcl_HashEntry *hPtr; + Tcl_HashSearch search; + register Command *cmdPtr; + DeleteCallback *dcPtr; + int i; + + /* + * If the interpreter is in use, delay the deletion until later. + */ + + iPtr->flags |= DELETED; + if (iPtr->numLevels != 0) { + return; + } + + /* + * Invoke deletion callbacks. + */ + + while (iPtr->deleteCallbackPtr != NULL) { + dcPtr = iPtr->deleteCallbackPtr; + iPtr->deleteCallbackPtr = dcPtr->nextPtr; + (*dcPtr->proc)(dcPtr->clientData, interp); + ckfree((char *) dcPtr); + } + + /* + * Free up any remaining resources associated with the + * interpreter. + */ + + for (hPtr = Tcl_FirstHashEntry(&iPtr->commandTable, &search); + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + cmdPtr = (Command *) Tcl_GetHashValue(hPtr); + if (cmdPtr->deleteProc != NULL) { + (*cmdPtr->deleteProc)(cmdPtr->deleteData); + } + ckfree((char *) cmdPtr); + } + Tcl_DeleteHashTable(&iPtr->commandTable); + for (hPtr = Tcl_FirstHashEntry(&iPtr->mathFuncTable, &search); + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + ckfree((char *) Tcl_GetHashValue(hPtr)); + } + Tcl_DeleteHashTable(&iPtr->mathFuncTable); + TclDeleteVars(iPtr, &iPtr->globalTable); + + /* + * Free up the result *after* deleting variables, since variable + * deletion could have transferred ownership of the result string + * to Tcl. + */ + + Tcl_FreeResult(interp); + if (iPtr->errorInfo != NULL) { + ckfree(iPtr->errorInfo); + } + if (iPtr->errorCode != NULL) { + ckfree(iPtr->errorCode); + } + if (iPtr->events != NULL) { + int i; + + for (i = 0; i < iPtr->numEvents; i++) { + ckfree(iPtr->events[i].command); + } + ckfree((char *) iPtr->events); + } + while (iPtr->revPtr != NULL) { + HistoryRev *nextPtr = iPtr->revPtr->nextPtr; + + ckfree((char *) iPtr->revPtr); + iPtr->revPtr = nextPtr; + } + if (iPtr->appendResult != NULL) { + ckfree(iPtr->appendResult); + } + for (i = 0; i < NUM_REGEXPS; i++) { + if (iPtr->patterns[i] == NULL) { + break; + } + ckfree(iPtr->patterns[i]); + ckfree((char *) iPtr->regexps[i]); + } + while (iPtr->tracePtr != NULL) { + Trace *nextPtr = iPtr->tracePtr->nextPtr; + + ckfree((char *) iPtr->tracePtr); + iPtr->tracePtr = nextPtr; + } + ckfree((char *) iPtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_CreateCommand -- + * + * Define a new command in a command table. + * + * Results: + * None. + * + * Side effects: + * If a command named cmdName already exists for interp, it is + * deleted. In the future, when cmdName is seen as the name of + * a command by Tcl_Eval, proc will be called. When the command + * is deleted from the table, deleteProc will be called. See the + * manual entry for details on the calling sequence. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_CreateCommand(interp, cmdName, proc, clientData, deleteProc) + Tcl_Interp *interp; /* Token for command interpreter (returned + * by a previous call to Tcl_CreateInterp). */ + char *cmdName; /* Name of command. */ + Tcl_CmdProc *proc; /* Command procedure to associate with + * cmdName. */ + ClientData clientData; /* Arbitrary one-word value to pass to proc. */ + Tcl_CmdDeleteProc *deleteProc; + /* If not NULL, gives a procedure to call when + * this command is deleted. */ +{ + Interp *iPtr = (Interp *) interp; + register Command *cmdPtr; + Tcl_HashEntry *hPtr; + int new; + + hPtr = Tcl_CreateHashEntry(&iPtr->commandTable, cmdName, &new); + if (!new) { + /* + * Command already exists: delete the old one. + */ + + cmdPtr = (Command *) Tcl_GetHashValue(hPtr); + if (cmdPtr->deleteProc != NULL) { + (*cmdPtr->deleteProc)(cmdPtr->deleteData); + } + } else { + cmdPtr = (Command *) ckalloc(sizeof(Command)); + Tcl_SetHashValue(hPtr, cmdPtr); + } + cmdPtr->proc = proc; + cmdPtr->clientData = clientData; + cmdPtr->deleteProc = deleteProc; + cmdPtr->deleteData = clientData; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetCommandInfo -- + * + * Modifies various information about a Tcl command. + * + * Results: + * If cmdName exists in interp, then the information at *infoPtr + * is stored with the command in place of the current information + * and 1 is returned. If the command doesn't exist then 0 is + * returned. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_SetCommandInfo(interp, cmdName, infoPtr) + Tcl_Interp *interp; /* Interpreter in which to look + * for command. */ + char *cmdName; /* Name of desired command. */ + Tcl_CmdInfo *infoPtr; /* Where to store information about + * command. */ +{ + Tcl_HashEntry *hPtr; + Command *cmdPtr; + + hPtr = Tcl_FindHashEntry(&((Interp *) interp)->commandTable, cmdName); + if (hPtr == NULL) { + return 0; + } + cmdPtr = (Command *) Tcl_GetHashValue(hPtr); + cmdPtr->proc = infoPtr->proc; + cmdPtr->clientData = infoPtr->clientData; + cmdPtr->deleteProc = infoPtr->deleteProc; + cmdPtr->deleteData = infoPtr->deleteData; + return 1; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetCommandInfo -- + * + * Returns various information about a Tcl command. + * + * Results: + * If cmdName exists in interp, then *infoPtr is modified to + * hold information about cmdName and 1 is returned. If the + * command doesn't exist then 0 is returned and *infoPtr isn't + * modified. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_GetCommandInfo(interp, cmdName, infoPtr) + Tcl_Interp *interp; /* Interpreter in which to look + * for command. */ + char *cmdName; /* Name of desired command. */ + Tcl_CmdInfo *infoPtr; /* Where to store information about + * command. */ +{ + Tcl_HashEntry *hPtr; + Command *cmdPtr; + + hPtr = Tcl_FindHashEntry(&((Interp *) interp)->commandTable, cmdName); + if (hPtr == NULL) { + return 0; + } + cmdPtr = (Command *) Tcl_GetHashValue(hPtr); + infoPtr->proc = cmdPtr->proc; + infoPtr->clientData = cmdPtr->clientData; + infoPtr->deleteProc = cmdPtr->deleteProc; + infoPtr->deleteData = cmdPtr->deleteData; + return 1; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DeleteCommand -- + * + * Remove the given command from the given interpreter. + * + * Results: + * 0 is returned if the command was deleted successfully. + * -1 is returned if there didn't exist a command by that + * name. + * + * Side effects: + * CmdName will no longer be recognized as a valid command for + * interp. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_DeleteCommand(interp, cmdName) + Tcl_Interp *interp; /* Token for command interpreter (returned + * by a previous call to Tcl_CreateInterp). */ + char *cmdName; /* Name of command to remove. */ +{ + Interp *iPtr = (Interp *) interp; + Tcl_HashEntry *hPtr; + Command *cmdPtr; + + hPtr = Tcl_FindHashEntry(&iPtr->commandTable, cmdName); + if (hPtr == NULL) { + return -1; + } + cmdPtr = (Command *) Tcl_GetHashValue(hPtr); + if (cmdPtr->deleteProc != NULL) { + (*cmdPtr->deleteProc)(cmdPtr->deleteData); + } + ckfree((char *) cmdPtr); + Tcl_DeleteHashEntry(hPtr); + return 0; +} + +/* + *----------------------------------------------------------------- + * + * Tcl_Eval -- + * + * Parse and execute a command in the Tcl language. + * + * Results: + * The return value is one of the return codes defined in tcl.hd + * (such as TCL_OK), and interp->result contains a string value + * to supplement the return code. The value of interp->result + * will persist only until the next call to Tcl_Eval: copy it or + * lose it! *TermPtr is filled in with the character just after + * the last one that was part of the command (usually a NULL + * character or a closing bracket). + * + * Side effects: + * Almost certainly; depends on the command. + * + *----------------------------------------------------------------- + */ + +int +Tcl_Eval(interp, cmd) + Tcl_Interp *interp; /* Token for command interpreter (returned + * by a previous call to Tcl_CreateInterp). */ + char *cmd; /* Pointer to TCL command to interpret. */ +{ + /* + * The storage immediately below is used to generate a copy + * of the command, after all argument substitutions. Pv will + * contain the argv values passed to the command procedure. +# define NUM_CHARS 1024 + */ + +# define NUM_CHARS 200 + char copyStorage[NUM_CHARS]; + ParseValue pv; + char *oldBuffer; + + /* + * This procedure generates an (argv, argc) array for the command, + * It starts out with stack-allocated space but uses dynamically- + * allocated storage to increase it if needed. + */ + +# define NUM_ARGS 10 + char *(argStorage[NUM_ARGS]); + char **argv = argStorage; + int argc; + int argSize = NUM_ARGS; + + register char *src; /* Points to current character + * in cmd. */ + char termChar; /* Return when this character is found + * (either ']' or '\0'). Zero means + * that newlines terminate commands. */ + int flags; /* Interp->evalFlags value when the + * procedure was called. */ + int result; /* Return value. */ + register Interp *iPtr = (Interp *) interp; + Tcl_HashEntry *hPtr; + Command *cmdPtr; + char *termPtr; /* Contains character just after the + * last one in the command. */ + char *cmdStart; /* Points to first non-blank char. in + * command (used in calling trace + * procedures). */ + char *ellipsis = ""; /* Used in setting errorInfo variable; + * set to "..." to indicate that not + * all of offending command is included + * in errorInfo. "" means that the + * command is all there. */ + register Trace *tracePtr; + + /* + * Initialize the result to an empty string and clear out any + * error information. This makes sure that we return an empty + * result if there are no commands in the command string. + */ + + Tcl_FreeResult((Tcl_Interp *) iPtr); + iPtr->result = iPtr->resultSpace; + iPtr->resultSpace[0] = 0; + result = TCL_OK; + + /* + * Initialize the area in which command copies will be assembled. + */ + + pv.buffer = copyStorage; + pv.end = copyStorage + NUM_CHARS - 1; + pv.expandProc = TclExpandParseValue; + pv.clientData = (ClientData) NULL; + + src = cmd; + flags = iPtr->evalFlags; + iPtr->evalFlags = 0; + if (flags & TCL_BRACKET_TERM) { + termChar = ']'; + } else { + termChar = 0; + } + termPtr = src; + cmdStart = src; + + /* + * Check depth of nested calls to Tcl_Eval: if this gets too large, + * it's probably because of an infinite loop somewhere. + */ + + iPtr->numLevels++; + if (iPtr->numLevels > iPtr->maxNestingDepth) { + iPtr->numLevels--; + iPtr->result = "too many nested calls to Tcl_Eval (infinite loop?)"; + iPtr->termPtr = termPtr; + return TCL_ERROR; + } + + /* + * There can be many sub-commands (separated by semi-colons or + * newlines) in one command string. This outer loop iterates over + * individual commands. + */ + + while (*src != termChar) { + iPtr->flags &= ~(ERR_IN_PROGRESS | ERROR_CODE_SET); + + /* + * Skim off leading white space and semi-colons, and skip + * comments. + */ + + while (1) { + register char c = *src; + + if ((CHAR_TYPE(c) != TCL_SPACE) && (c != ';') && (c != '\n')) { + break; + } + src += 1; + } + if (*src == '#') { + for (src++; *src != 0; src++) { + if ((*src == '\n') && (src[-1] != '\\')) { + src++; + break; + } + } + continue; + } + cmdStart = src; + + /* + * Parse the words of the command, generating the argc and + * argv for the command procedure. May have to call + * TclParseWords several times, expanding the argv array + * between calls. + */ + + pv.next = oldBuffer = pv.buffer; + argc = 0; + while (1) { + int newArgs, maxArgs; + char **newArgv; + int i; + + /* + * Note: the "- 2" below guarantees that we won't use the + * last two argv slots here. One is for a NULL pointer to + * mark the end of the list, and the other is to leave room + * for inserting the command name "unknown" as the first + * argument (see below). + */ + + maxArgs = argSize - argc - 2; + result = TclParseWords((Tcl_Interp *) iPtr, src, flags, + maxArgs, &termPtr, &newArgs, &argv[argc], &pv); + src = termPtr; + if (result != TCL_OK) { + ellipsis = "..."; + goto done; + } + + /* + * Careful! Buffer space may have gotten reallocated while + * parsing words. If this happened, be sure to update all + * of the older argv pointers to refer to the new space. + */ + + if (oldBuffer != pv.buffer) { + int i; + + for (i = 0; i < argc; i++) { + argv[i] = pv.buffer + (argv[i] - oldBuffer); + } + oldBuffer = pv.buffer; + } + argc += newArgs; + if (newArgs < maxArgs) { + argv[argc] = (char *) NULL; + break; + } + + /* + * Args didn't all fit in the current array. Make it bigger. + */ + + argSize *= 2; + newArgv = (char **) + ckalloc((unsigned) argSize * sizeof(char *)); + for (i = 0; i < argc; i++) { + newArgv[i] = argv[i]; + } + if (argv != argStorage) { + ckfree((char *) argv); + } + argv = newArgv; + } + + /* + * If this is an empty command (or if we're just parsing + * commands without evaluating them), then just skip to the + * next command. + */ + + if ((argc == 0) || iPtr->noEval) { + continue; + } + argv[argc] = NULL; + + /* + * Save information for the history module, if needed. + */ + + if (flags & TCL_RECORD_BOUNDS) { + iPtr->evalFirst = cmdStart; + iPtr->evalLast = src-1; + } + + /* + * Find the procedure to execute this command. If there isn't + * one, then see if there is a command "unknown". If so, + * invoke it instead, passing it the words of the original + * command as arguments. + */ + + hPtr = Tcl_FindHashEntry(&iPtr->commandTable, argv[0]); + if (hPtr == NULL) { + int i; + + hPtr = Tcl_FindHashEntry(&iPtr->commandTable, "unknown"); + if (hPtr == NULL) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "invalid command name: \"", + argv[0], "\"", (char *) NULL); + result = TCL_ERROR; + goto done; + } + for (i = argc; i >= 0; i--) { + argv[i+1] = argv[i]; + } + argv[0] = "unknown"; + argc++; + } + cmdPtr = (Command *) Tcl_GetHashValue(hPtr); + + /* + * Call trace procedures, if any. + */ + + for (tracePtr = iPtr->tracePtr; tracePtr != NULL; + tracePtr = tracePtr->nextPtr) { + char saved; + + if (tracePtr->level < iPtr->numLevels) { + continue; + } + saved = *src; + *src = 0; + (*tracePtr->proc)(tracePtr->clientData, interp, iPtr->numLevels, + cmdStart, cmdPtr->proc, cmdPtr->clientData, argc, argv); + *src = saved; + } + + /* + * At long last, invoke the command procedure. Reset the + * result to its default empty value first (it could have + * gotten changed by earlier commands in the same command + * string). + */ + + iPtr->cmdCount++; + Tcl_FreeResult(iPtr); + iPtr->result = iPtr->resultSpace; + iPtr->resultSpace[0] = 0; + result = (*cmdPtr->proc)(cmdPtr->clientData, interp, argc, argv); + if (tcl_AsyncReady) { + result = Tcl_AsyncInvoke(interp, result); + } + if (result != TCL_OK) { + break; + } + } + + /* + * Free up any extra resources that were allocated. + */ + + done: + if (pv.buffer != copyStorage) { + ckfree((char *) pv.buffer); + } + if (argv != argStorage) { + ckfree((char *) argv); + } + iPtr->numLevels--; + if (iPtr->numLevels == 0) { + if (result == TCL_RETURN) { + result = TCL_OK; + } + if ((result != TCL_OK) && (result != TCL_ERROR)) { + Tcl_ResetResult(interp); + if (result == TCL_BREAK) { + iPtr->result = "invoked \"break\" outside of a loop"; + } else if (result == TCL_CONTINUE) { + iPtr->result = "invoked \"continue\" outside of a loop"; + } else { + iPtr->result = iPtr->resultSpace; + sprintf(iPtr->resultSpace, "command returned bad code: %d", + result); + } + result = TCL_ERROR; + } + if (iPtr->flags & DELETED) { + Tcl_DeleteInterp(interp); + } + } + + /* + * If an error occurred, record information about what was being + * executed when the error occurred. + */ + + if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) { + int numChars; + register char *p; + + /* + * Compute the line number where the error occurred. + */ + + iPtr->errorLine = 1; + for (p = cmd; p != cmdStart; p++) { + if (*p == '\n') { + iPtr->errorLine++; + } + } + for ( ; isspace(UCHAR(*p)) || (*p == ';'); p++) { + if (*p == '\n') { + iPtr->errorLine++; + } + } + + /* + * Figure out how much of the command to print in the error + * message (up to a certain number of characters, or up to + * the first new-line). + */ + + numChars = src - cmdStart; + if (numChars > (NUM_CHARS-50)) { + numChars = NUM_CHARS-50; + ellipsis = " ..."; + } + + if (!(iPtr->flags & ERR_IN_PROGRESS)) { + sprintf(copyStorage, "\n while executing\n\"%.*s%s\"", + numChars, cmdStart, ellipsis); + } else { + sprintf(copyStorage, "\n invoked from within\n\"%.*s%s\"", + numChars, cmdStart, ellipsis); + } + Tcl_AddErrorInfo(interp, copyStorage); + iPtr->flags &= ~ERR_ALREADY_LOGGED; + } else { + iPtr->flags &= ~ERR_ALREADY_LOGGED; + } + iPtr->termPtr = termPtr; + return result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_CreateTrace -- + * + * Arrange for a procedure to be called to trace command execution. + * + * Results: + * The return value is a token for the trace, which may be passed + * to Tcl_DeleteTrace to eliminate the trace. + * + * Side effects: + * From now on, proc will be called just before a command procedure + * is called to execute a Tcl command. Calls to proc will have the + * following form: + * + * void + * proc(clientData, interp, level, command, cmdProc, cmdClientData, + * argc, argv) + * ClientData clientData; + * Tcl_Interp *interp; + * int level; + * char *command; + * int (*cmdProc)(); + * ClientData cmdClientData; + * int argc; + * char **argv; + * { + * } + * + * The clientData and interp arguments to proc will be the same + * as the corresponding arguments to this procedure. Level gives + * the nesting level of command interpretation for this interpreter + * (0 corresponds to top level). Command gives the ASCII text of + * the raw command, cmdProc and cmdClientData give the procedure that + * will be called to process the command and the ClientData value it + * will receive, and argc and argv give the arguments to the + * command, after any argument parsing and substitution. Proc + * does not return a value. + * + *---------------------------------------------------------------------- + */ + +Tcl_Trace +Tcl_CreateTrace(interp, level, proc, clientData) + Tcl_Interp *interp; /* Interpreter in which to create the trace. */ + int level; /* Only call proc for commands at nesting level + * <= level (1 => top level). */ + Tcl_CmdTraceProc *proc; /* Procedure to call before executing each + * command. */ + ClientData clientData; /* Arbitrary one-word value to pass to proc. */ +{ + register Trace *tracePtr; + register Interp *iPtr = (Interp *) interp; + + tracePtr = (Trace *) ckalloc(sizeof(Trace)); + tracePtr->level = level; + tracePtr->proc = proc; + tracePtr->clientData = clientData; + tracePtr->nextPtr = iPtr->tracePtr; + iPtr->tracePtr = tracePtr; + + return (Tcl_Trace) tracePtr; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DeleteTrace -- + * + * Remove a trace. + * + * Results: + * None. + * + * Side effects: + * From now on there will be no more calls to the procedure given + * in trace. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DeleteTrace(interp, trace) + Tcl_Interp *interp; /* Interpreter that contains trace. */ + Tcl_Trace trace; /* Token for trace (returned previously by + * Tcl_CreateTrace). */ +{ + register Interp *iPtr = (Interp *) interp; + register Trace *tracePtr = (Trace *) trace; + register Trace *tracePtr2; + + if (iPtr->tracePtr == tracePtr) { + iPtr->tracePtr = tracePtr->nextPtr; + ckfree((char *) tracePtr); + } else { + for (tracePtr2 = iPtr->tracePtr; tracePtr2 != NULL; + tracePtr2 = tracePtr2->nextPtr) { + if (tracePtr2->nextPtr == tracePtr) { + tracePtr2->nextPtr = tracePtr->nextPtr; + ckfree((char *) tracePtr); + return; + } + } + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_AddErrorInfo -- + * + * Add information to a message being accumulated that describes + * the current error. + * + * Results: + * None. + * + * Side effects: + * The contents of message are added to the "errorInfo" variable. + * If Tcl_Eval has been called since the current value of errorInfo + * was set, errorInfo is cleared before adding the new message. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_AddErrorInfo(interp, message) + Tcl_Interp *interp; /* Interpreter to which error information + * pertains. */ + char *message; /* Message to record. */ +{ + register Interp *iPtr = (Interp *) interp; + + /* + * If an error is already being logged, then the new errorInfo + * is the concatenation of the old info and the new message. + * If this is the first piece of info for the error, then the + * new errorInfo is the concatenation of the message in + * interp->result and the new message. + */ + + if (!(iPtr->flags & ERR_IN_PROGRESS)) { + Tcl_SetVar2(interp, "errorInfo", (char *) NULL, interp->result, + TCL_GLOBAL_ONLY); + iPtr->flags |= ERR_IN_PROGRESS; + + /* + * If the errorCode variable wasn't set by the code that generated + * the error, set it to "NONE". + */ + + if (!(iPtr->flags & ERROR_CODE_SET)) { + (void) Tcl_SetVar2(interp, "errorCode", (char *) NULL, "NONE", + TCL_GLOBAL_ONLY); + } + } + Tcl_SetVar2(interp, "errorInfo", (char *) NULL, message, + TCL_GLOBAL_ONLY|TCL_APPEND_VALUE); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_VarEval -- + * + * Given a variable number of string arguments, concatenate them + * all together and execute the result as a Tcl command. + * + * Results: + * A standard Tcl return result. An error message or other + * result may be left in interp->result. + * + * Side effects: + * Depends on what was done by the command. + * + *---------------------------------------------------------------------- + */ + /* VARARGS2 */ /* ARGSUSED */ +int +#ifdef USE_STDARG +Tcl_VarEval(Tcl_Interp *iPtr, ...) +#else + +#ifndef lint +Tcl_VarEval(va_alist) +#else +Tcl_VarEval(iPtr, p, va_alist) + Tcl_Interp *iPtr; /* Interpreter in which to execute command. */ + char *p; /* One or more strings to concatenate, + * terminated with a NULL string. */ +#endif + + va_dcl +#endif +{ + va_list argList; + +#define FIXED_SIZE 200 + char fixedSpace[FIXED_SIZE+1]; + int spaceAvl, spaceUsed, length; + char *string, *cmd; + Tcl_Interp *interp = iPtr; + int result; + + /* + * Copy the strings one after the other into a single larger + * string. Use stack-allocated space for small commands, but if + * the command gets too large than call ckalloc to create the + * space. + */ + +#ifdef USE_STDARG + va_start(argList, iPtr); +#else + va_start(argList); + (void) va_arg(argList, Tcl_Interp *); +#endif + spaceAvl = FIXED_SIZE; + spaceUsed = 0; + cmd = fixedSpace; + while (1) { + string = va_arg(argList, char *); + if (string == NULL) { + break; + } + length = strlen(string); + if ((spaceUsed + length) > spaceAvl) { + char *new; + + spaceAvl = spaceUsed + length; + spaceAvl += spaceAvl/2; + new = ckalloc((unsigned) spaceAvl); + memcpy((VOID *) new, (VOID *) cmd, spaceUsed); + if (cmd != fixedSpace) { + ckfree(cmd); + } + cmd = new; + } + strcpy(cmd + spaceUsed, string); + spaceUsed += length; + } + va_end(argList); + cmd[spaceUsed] = '\0'; + + result = Tcl_Eval(interp, cmd); + if (cmd != fixedSpace) { + ckfree(cmd); + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GlobalEval -- + * + * Evaluate a command at global level in an interpreter. + * + * Results: + * A standard Tcl result is returned, and interp->result is + * modified accordingly. + * + * Side effects: + * The command string is executed in interp, and the execution + * is carried out in the variable context of global level (no + * procedures active), just as if an "uplevel #0" command were + * being executed. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_GlobalEval(interp, command) + Tcl_Interp *interp; /* Interpreter in which to evaluate command. */ + char *command; /* Command to evaluate. */ +{ + register Interp *iPtr = (Interp *) interp; + int result; + CallFrame *savedVarFramePtr; + + savedVarFramePtr = iPtr->varFramePtr; + iPtr->varFramePtr = NULL; + result = Tcl_Eval(interp, command); + iPtr->varFramePtr = savedVarFramePtr; + return result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetRecursionLimit -- + * + * Set the maximum number of recursive calls that may be active + * for an interpreter at once. + * + * Results: + * The return value is the old limit on nesting for interp. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_SetRecursionLimit(interp, depth) + Tcl_Interp *interp; /* Interpreter whose nesting limit + * is to be set. */ + int depth; /* New value for maximimum depth. */ +{ + Interp *iPtr = (Interp *) interp; + int old; + + old = iPtr->maxNestingDepth; + if (depth > 0) { + iPtr->maxNestingDepth = depth; + } + return old; +} diff --git a/vendor/x11iraf/obm/Tcl/tclCkalloc.c b/vendor/x11iraf/obm/Tcl/tclCkalloc.c new file mode 100644 index 00000000..6f049224 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/tclCkalloc.c @@ -0,0 +1,607 @@ +/* + * tclCkalloc.c -- + * Interface to malloc and free that provides support for debugging problems + * involving overwritten, double freeing memory and loss of memory. + * + * Copyright (c) 1991-1993 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. + * + * This code contributed by Karl Lehenbauer and Mark Diekhans + * + */ + +#include "tclInt.h" + +#define FALSE 0 +#define TRUE 1 + +#ifdef TCL_MEM_DEBUG +#ifndef TCL_GENERIC_ONLY +#include "tclUnix.h" +#endif + +#define GUARD_SIZE 8 + +struct mem_header { + long length; + char *file; + int line; + struct mem_header *flink; + struct mem_header *blink; + int dummy; /* Aligns body on 8-byte boundary. */ + unsigned char low_guard[GUARD_SIZE]; + char body[1]; +}; + +static struct mem_header *allocHead = NULL; /* List of allocated structures */ + +#define GUARD_VALUE 0341 + +/* static char high_guard[] = {0x89, 0xab, 0xcd, 0xef}; */ + +static int total_mallocs = 0; +static int total_frees = 0; +static int current_bytes_malloced = 0; +static int maximum_bytes_malloced = 0; +static int current_malloc_packets = 0; +static int maximum_malloc_packets = 0; +static int break_on_malloc = 0; +static int trace_on_at_malloc = 0; +static int alloc_tracing = FALSE; +static int init_malloced_bodies = TRUE; +#ifdef MEM_VALIDATE + static int validate_memory = TRUE; +#else + static int validate_memory = FALSE; +#endif + +/* + * Prototypes for procedures defined in this file: + */ + +static int MemoryCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); + +/* + *---------------------------------------------------------------------- + * + * dump_memory_info -- + * Display the global memory management statistics. + * + *---------------------------------------------------------------------- + */ +static void +dump_memory_info(outFile) + FILE *outFile; +{ + fprintf(outFile,"total mallocs %10d\n", + total_mallocs); + fprintf(outFile,"total frees %10d\n", + total_frees); + fprintf(outFile,"current packets allocated %10d\n", + current_malloc_packets); + fprintf(outFile,"current bytes allocated %10d\n", + current_bytes_malloced); + fprintf(outFile,"maximum packets allocated %10d\n", + maximum_malloc_packets); + fprintf(outFile,"maximum bytes allocated %10d\n", + maximum_bytes_malloced); +} + +/* + *---------------------------------------------------------------------- + * + * ValidateMemory -- + * Procedure to validate allocted memory guard zones. + * + *---------------------------------------------------------------------- + */ +static void +ValidateMemory (memHeaderP, file, line, nukeGuards) + struct mem_header *memHeaderP; + char *file; + int line; + int nukeGuards; +{ + unsigned char *hiPtr; + int idx; + int guard_failed = FALSE; + int byte; + + for (idx = 0; idx < GUARD_SIZE; idx++) { + byte = *(memHeaderP->low_guard + idx); + if (byte != GUARD_VALUE) { + guard_failed = TRUE; + fflush (stdout); + byte &= 0xff; + fprintf(stderr, "low guard byte %d is 0x%x \t%c\n", idx, byte, + (isprint(UCHAR(byte)) ? byte : ' ')); + } + } + if (guard_failed) { + dump_memory_info (stderr); + fprintf (stderr, "low guard failed at %lx, %s %d\n", + memHeaderP->body, file, line); + fflush (stderr); /* In case name pointer is bad. */ + fprintf (stderr, "%d bytes allocated at (%s %d)\n", memHeaderP->length, + memHeaderP->file, memHeaderP->line); + panic ("Memory validation failure"); + } + + hiPtr = (unsigned char *)memHeaderP->body + memHeaderP->length; + for (idx = 0; idx < GUARD_SIZE; idx++) { + byte = *(hiPtr + idx); + if (byte != GUARD_VALUE) { + guard_failed = TRUE; + fflush (stdout); + byte &= 0xff; + fprintf(stderr, "hi guard byte %d is 0x%x \t%c\n", idx, byte, + (isprint(UCHAR(byte)) ? byte : ' ')); + } + } + + if (guard_failed) { + dump_memory_info (stderr); + fprintf (stderr, "high guard failed at %lx, %s %d\n", + memHeaderP->body, file, line); + fflush (stderr); /* In case name pointer is bad. */ + fprintf (stderr, "%d bytes allocated at (%s %d)\n", memHeaderP->length, + memHeaderP->file, memHeaderP->line); + panic ("Memory validation failure"); + } + + if (nukeGuards) { + memset ((char *) memHeaderP->low_guard, 0, GUARD_SIZE); + memset ((char *) hiPtr, 0, GUARD_SIZE); + } + +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ValidateAllMemory -- + * Validates guard regions for all allocated memory. + * + *---------------------------------------------------------------------- + */ +void +Tcl_ValidateAllMemory (file, line) + char *file; + int line; +{ + struct mem_header *memScanP; + + for (memScanP = allocHead; memScanP != NULL; memScanP = memScanP->flink) + ValidateMemory (memScanP, file, line, FALSE); + +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DumpActiveMemory -- + * Displays all allocated memory to stderr. + * + * Results: + * Return TCL_ERROR if an error accessing the file occures, `errno' + * will have the file error number left in it. + *---------------------------------------------------------------------- + */ +int +Tcl_DumpActiveMemory (fileName) + char *fileName; +{ + FILE *fileP; + struct mem_header *memScanP; + char *address; + + fileP = fopen (fileName, "w"); + if (fileP == NULL) + return TCL_ERROR; + + for (memScanP = allocHead; memScanP != NULL; memScanP = memScanP->flink) { + address = &memScanP->body [0]; + fprintf (fileP, "%8lx - %8lx %7d @ %s %d", address, + address + memScanP->length - 1, memScanP->length, + memScanP->file, memScanP->line); + (void) fputc('\n', fileP); + } + fclose (fileP); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DbCkalloc - debugging ckalloc + * + * Allocate the requested amount of space plus some extra for + * guard bands at both ends of the request, plus a size, panicing + * if there isn't enough space, then write in the guard bands + * and return the address of the space in the middle that the + * user asked for. + * + * The second and third arguments are file and line, these contain + * the filename and line number corresponding to the caller. + * These are sent by the ckalloc macro; it uses the preprocessor + * autodefines __FILE__ and __LINE__. + * + *---------------------------------------------------------------------- + */ +char * +Tcl_DbCkalloc(size, file, line) + unsigned int size; + char *file; + int line; +{ + struct mem_header *result; + + if (validate_memory) + Tcl_ValidateAllMemory (file, line); + + result = (struct mem_header *)malloc((unsigned)size + + sizeof(struct mem_header) + GUARD_SIZE); + if (result == NULL) { + fflush(stdout); + dump_memory_info(stderr); + panic("unable to alloc %d bytes, %s line %d", size, file, + line); + } + + /* + * Fill in guard zones and size. Also initialize the contents of + * the block with bogus bytes to detect uses of initialized data. + * Link into allocated list. + */ + if (init_malloced_bodies) { + memset ((VOID *) result, GUARD_VALUE, + size + sizeof(struct mem_header) + GUARD_SIZE); + } else { + memset ((char *) result->low_guard, GUARD_VALUE, GUARD_SIZE); + memset (result->body + size, GUARD_VALUE, GUARD_SIZE); + } + result->length = size; + result->file = file; + result->line = line; + result->flink = allocHead; + result->blink = NULL; + if (allocHead != NULL) + allocHead->blink = result; + allocHead = result; + + total_mallocs++; + if (trace_on_at_malloc && (total_mallocs >= trace_on_at_malloc)) { + (void) fflush(stdout); + fprintf(stderr, "reached malloc trace enable point (%d)\n", + total_mallocs); + fflush(stderr); + alloc_tracing = TRUE; + trace_on_at_malloc = 0; + } + + if (alloc_tracing) + fprintf(stderr,"ckalloc %lx %d %s %d\n", result->body, size, + file, line); + + if (break_on_malloc && (total_mallocs >= break_on_malloc)) { + break_on_malloc = 0; + (void) fflush(stdout); + fprintf(stderr,"reached malloc break limit (%d)\n", + total_mallocs); + fprintf(stderr, "program will now enter C debugger\n"); + (void) fflush(stderr); + abort(); + } + + current_malloc_packets++; + if (current_malloc_packets > maximum_malloc_packets) + maximum_malloc_packets = current_malloc_packets; + current_bytes_malloced += size; + if (current_bytes_malloced > maximum_bytes_malloced) + maximum_bytes_malloced = current_bytes_malloced; + + return result->body; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DbCkfree - debugging ckfree + * + * Verify that the low and high guards are intact, and if so + * then free the buffer else panic. + * + * The guards are erased after being checked to catch duplicate + * frees. + * + * The second and third arguments are file and line, these contain + * the filename and line number corresponding to the caller. + * These are sent by the ckfree macro; it uses the preprocessor + * autodefines __FILE__ and __LINE__. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_DbCkfree(ptr, file, line) + char * ptr; + char *file; + int line; +{ + struct mem_header *memp = 0; /* Must be zero for size calc */ + + /* + * Since header ptr is zero, body offset will be size + */ +#ifdef _CRAYCOM + memp = (struct mem_header *)((char *) ptr - (sizeof(int)*((unsigned)&(memp->body)))); +#else + memp = (struct mem_header *)(((char *) ptr) - (int)memp->body); +#endif + + if (alloc_tracing) + fprintf(stderr, "ckfree %lx %ld %s %d\n", memp->body, + memp->length, file, line); + + if (validate_memory) + Tcl_ValidateAllMemory (file, line); + + ValidateMemory (memp, file, line, TRUE); + if (init_malloced_bodies) { + memset((VOID *) ptr, GUARD_VALUE, memp->length); + } + + total_frees++; + current_malloc_packets--; + current_bytes_malloced -= memp->length; + + /* + * Delink from allocated list + */ + if (memp->flink != NULL) + memp->flink->blink = memp->blink; + if (memp->blink != NULL) + memp->blink->flink = memp->flink; + if (allocHead == memp) + allocHead = memp->flink; + free((char *) memp); + return 0; +} + +/* + *-------------------------------------------------------------------- + * + * Tcl_DbCkrealloc - debugging ckrealloc + * + * Reallocate a chunk of memory by allocating a new one of the + * right size, copying the old data to the new location, and then + * freeing the old memory space, using all the memory checking + * features of this package. + * + *-------------------------------------------------------------------- + */ +char * +Tcl_DbCkrealloc(ptr, size, file, line) + char *ptr; + unsigned int size; + char *file; + int line; +{ + char *new; + unsigned int copySize; + struct mem_header *memp = 0; /* Must be zero for size calc */ + +#ifdef _CRAYCOM + memp = (struct mem_header *)((char *) ptr - (sizeof(int)*((unsigned)&(memp->body)))); +#else + memp = (struct mem_header *)(((char *) ptr) - (int)memp->body); +#endif + copySize = size; + if (copySize > memp->length) { + copySize = memp->length; + } + new = Tcl_DbCkalloc(size, file, line); + memcpy((VOID *) new, (VOID *) ptr, (int) copySize); + Tcl_DbCkfree(ptr, file, line); + return(new); +} + +/* + *---------------------------------------------------------------------- + * + * MemoryCmd -- + * Implements the TCL memory command: + * memory info + * memory display + * break_on_malloc count + * trace_on_at_malloc count + * trace on|off + * validate on|off + * + * Results: + * Standard TCL results. + * + *---------------------------------------------------------------------- + */ + /* ARGSUSED */ +static int +MemoryCmd (clientData, interp, argc, argv) + ClientData clientData; + Tcl_Interp *interp; + int argc; + char **argv; +{ + char *fileName; + Tcl_DString buffer; + int result; + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " option [args..]\"", (char *) NULL); + return TCL_ERROR; + } + + if (strcmp(argv[1],"trace") == 0) { + if (argc != 3) + goto bad_suboption; + alloc_tracing = (strcmp(argv[2],"on") == 0); + return TCL_OK; + } + if (strcmp(argv[1],"init") == 0) { + if (argc != 3) + goto bad_suboption; + init_malloced_bodies = (strcmp(argv[2],"on") == 0); + return TCL_OK; + } + if (strcmp(argv[1],"validate") == 0) { + if (argc != 3) + goto bad_suboption; + validate_memory = (strcmp(argv[2],"on") == 0); + return TCL_OK; + } + if (strcmp(argv[1],"trace_on_at_malloc") == 0) { + if (argc != 3) + goto argError; + if (Tcl_GetInt(interp, argv[2], &trace_on_at_malloc) != TCL_OK) + return TCL_ERROR; + return TCL_OK; + } + if (strcmp(argv[1],"break_on_malloc") == 0) { + if (argc != 3) + goto argError; + if (Tcl_GetInt(interp, argv[2], &break_on_malloc) != TCL_OK) + return TCL_ERROR; + return TCL_OK; + } + + if (strcmp(argv[1],"info") == 0) { + dump_memory_info(stdout); + return TCL_OK; + } + if (strcmp(argv[1],"active") == 0) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " active file", (char *) NULL); + return TCL_ERROR; + } + fileName = Tcl_TildeSubst(interp, argv[2], &buffer); + if (fileName == NULL) { + return TCL_ERROR; + } + result = Tcl_DumpActiveMemory (fileName); + Tcl_DStringFree(&buffer); + if (result != TCL_OK) { + Tcl_AppendResult(interp, "error accessing ", argv[2], + (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; + } + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": should be info, init, active, break_on_malloc, ", + "trace_on_at_malloc, trace, or validate", (char *) NULL); + return TCL_ERROR; + +argError: + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " ", argv[1], "count\"", (char *) NULL); + return TCL_ERROR; + +bad_suboption: + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " ", argv[1], " on|off\"", (char *) NULL); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_InitMemory -- + * Initialize the memory command. + * + *---------------------------------------------------------------------- + */ +void +Tcl_InitMemory(interp) + Tcl_Interp *interp; +{ +Tcl_CreateCommand (interp, "memory", MemoryCmd, (ClientData) NULL, + (Tcl_CmdDeleteProc *) NULL); +} + +#else + + +/* + *---------------------------------------------------------------------- + * + * Tcl_Ckalloc -- + * Interface to malloc when TCL_MEM_DEBUG is disabled. It does check + * that memory was actually allocated. + * + *---------------------------------------------------------------------- + */ +VOID * +Tcl_Ckalloc (size) + unsigned int size; +{ + char *result; + + result = malloc(size); + if (result == NULL) + panic("unable to alloc %d bytes", size); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * TckCkfree -- + * Interface to free when TCL_MEM_DEBUG is disabled. Done here rather + * in the macro to keep some modules from being compiled with + * TCL_MEM_DEBUG enabled and some with it disabled. + * + *---------------------------------------------------------------------- + */ +void +Tcl_Ckfree (ptr) + VOID *ptr; +{ + free (ptr); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_InitMemory -- + * Dummy initialization for memory command, which is only available + * if TCL_MEM_DEBUG is on. + * + *---------------------------------------------------------------------- + */ + /* ARGSUSED */ +void +Tcl_InitMemory(interp) + Tcl_Interp *interp; +{ +} + +#endif diff --git a/vendor/x11iraf/obm/Tcl/tclCmdAH.c b/vendor/x11iraf/obm/Tcl/tclCmdAH.c new file mode 100644 index 00000000..5238804b --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/tclCmdAH.c @@ -0,0 +1,952 @@ +/* + * tclCmdAH.c -- + * + * This file contains the top-level command routines for most of + * the Tcl built-in commands whose names begin with the letters + * A to H. + * + * Copyright (c) 1987-1993 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. + */ + +#ifndef lint +static char rcsid[] = "$Header: /user6/ouster/tcl/RCS/tclCmdAH.c,v 1.93 93/10/28 16:19:20 ouster Exp $ SPRITE (Berkeley)"; +#endif + +#include "tclInt.h" + + +/* + *---------------------------------------------------------------------- + * + * Tcl_BreakCmd -- + * + * This procedure is invoked to process the "break" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_BreakCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + if (argc != 1) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], "\"", (char *) NULL); + return TCL_ERROR; + } + return TCL_BREAK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_CaseCmd -- + * + * This procedure is invoked to process the "case" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_CaseCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int i, result; + int body; + char *string; + int caseArgc, splitArgs; + char **caseArgv; + + if (argc < 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " string ?in? patList body ... ?default body?\"", + (char *) NULL); + return TCL_ERROR; + } + string = argv[1]; + body = -1; + if (strcmp(argv[2], "in") == 0) { + i = 3; + } else { + i = 2; + } + caseArgc = argc - i; + caseArgv = argv + i; + + /* + * If all of the pattern/command pairs are lumped into a single + * argument, split them out again. + */ + + splitArgs = 0; + if (caseArgc == 1) { + result = Tcl_SplitList(interp, caseArgv[0], &caseArgc, &caseArgv); + if (result != TCL_OK) { + return result; + } + splitArgs = 1; + } + + for (i = 0; i < caseArgc; i += 2) { + int patArgc, j; + char **patArgv; + register char *p; + + if (i == (caseArgc-1)) { + interp->result = "extra case pattern with no body"; + result = TCL_ERROR; + goto cleanup; + } + + /* + * Check for special case of single pattern (no list) with + * no backslash sequences. + */ + + for (p = caseArgv[i]; *p != 0; p++) { + if (isspace(UCHAR(*p)) || (*p == '\\')) { + break; + } + } + if (*p == 0) { + if ((*caseArgv[i] == 'd') + && (strcmp(caseArgv[i], "default") == 0)) { + body = i+1; + } + if (Tcl_StringMatch(string, caseArgv[i])) { + body = i+1; + goto match; + } + continue; + } + + /* + * Break up pattern lists, then check each of the patterns + * in the list. + */ + + result = Tcl_SplitList(interp, caseArgv[i], &patArgc, &patArgv); + if (result != TCL_OK) { + goto cleanup; + } + for (j = 0; j < patArgc; j++) { + if (Tcl_StringMatch(string, patArgv[j])) { + body = i+1; + break; + } + } + ckfree((char *) patArgv); + if (j < patArgc) { + break; + } + } + + match: + if (body != -1) { + result = Tcl_Eval(interp, caseArgv[body]); + if (result == TCL_ERROR) { + char msg[100]; + sprintf(msg, "\n (\"%.50s\" arm line %d)", caseArgv[body-1], + interp->errorLine); + Tcl_AddErrorInfo(interp, msg); + } + goto cleanup; + } + + /* + * Nothing matched: return nothing. + */ + + result = TCL_OK; + + cleanup: + if (splitArgs) { + ckfree((char *) caseArgv); + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_CatchCmd -- + * + * This procedure is invoked to process the "catch" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_CatchCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int result; + + if ((argc != 2) && (argc != 3)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " command ?varName?\"", (char *) NULL); + return TCL_ERROR; + } + result = Tcl_Eval(interp, argv[1]); + if (argc == 3) { + if (Tcl_SetVar(interp, argv[2], interp->result, 0) == NULL) { + Tcl_SetResult(interp, "couldn't save command result in variable", + TCL_STATIC); + return TCL_ERROR; + } + } + Tcl_ResetResult(interp); + sprintf(interp->result, "%d", result); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ConcatCmd -- + * + * This procedure is invoked to process the "concat" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_ConcatCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + if (argc >= 2) { + interp->result = Tcl_Concat(argc-1, argv+1); + interp->freeProc = (Tcl_FreeProc *) free; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ContinueCmd -- + * + * This procedure is invoked to process the "continue" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_ContinueCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + if (argc != 1) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + "\"", (char *) NULL); + return TCL_ERROR; + } + return TCL_CONTINUE; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ErrorCmd -- + * + * This procedure is invoked to process the "error" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_ErrorCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Interp *iPtr = (Interp *) interp; + + if ((argc < 2) || (argc > 4)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " message ?errorInfo? ?errorCode?\"", (char *) NULL); + return TCL_ERROR; + } + if ((argc >= 3) && (argv[2][0] != 0)) { + Tcl_AddErrorInfo(interp, argv[2]); + iPtr->flags |= ERR_ALREADY_LOGGED; + } + if (argc == 4) { + Tcl_SetVar2(interp, "errorCode", (char *) NULL, argv[3], + TCL_GLOBAL_ONLY); + iPtr->flags |= ERROR_CODE_SET; + } + Tcl_SetResult(interp, argv[1], TCL_VOLATILE); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_EvalCmd -- + * + * This procedure is invoked to process the "eval" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_EvalCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int result; + char *cmd; + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " arg ?arg ...?\"", (char *) NULL); + return TCL_ERROR; + } + if (argc == 2) { + result = Tcl_Eval(interp, argv[1]); + } else { + + /* + * More than one argument: concatenate them together with spaces + * between, then evaluate the result. + */ + + cmd = Tcl_Concat(argc-1, argv+1); + result = Tcl_Eval(interp, cmd); + ckfree(cmd); + } + if (result == TCL_ERROR) { + char msg[60]; + sprintf(msg, "\n (\"eval\" body line %d)", interp->errorLine); + Tcl_AddErrorInfo(interp, msg); + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ExprCmd -- + * + * This procedure is invoked to process the "expr" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_ExprCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Tcl_DString buffer; + int i, result; + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " arg ?arg ...?\"", (char *) NULL); + return TCL_ERROR; + } + + if (argc == 2) { + return Tcl_ExprString(interp, argv[1]); + } + Tcl_DStringInit(&buffer); + Tcl_DStringAppend(&buffer, argv[1], -1); + for (i = 2; i < argc; i++) { + Tcl_DStringAppend(&buffer, " ", 1); + Tcl_DStringAppend(&buffer, argv[i], -1); + } + result = Tcl_ExprString(interp, buffer.string); + Tcl_DStringFree(&buffer); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ForCmd -- + * + * This procedure is invoked to process the "for" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_ForCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int result, value; + + if (argc != 5) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " start test next command\"", (char *) NULL); + return TCL_ERROR; + } + + result = Tcl_Eval(interp, argv[1]); + if (result != TCL_OK) { + if (result == TCL_ERROR) { + Tcl_AddErrorInfo(interp, "\n (\"for\" initial command)"); + } + return result; + } + while (1) { + result = Tcl_ExprBoolean(interp, argv[2], &value); + if (result != TCL_OK) { + return result; + } + if (!value) { + break; + } + result = Tcl_Eval(interp, argv[4]); + if ((result != TCL_OK) && (result != TCL_CONTINUE)) { + if (result == TCL_ERROR) { + char msg[60]; + sprintf(msg, "\n (\"for\" body line %d)", interp->errorLine); + Tcl_AddErrorInfo(interp, msg); + } + break; + } + result = Tcl_Eval(interp, argv[3]); + if (result == TCL_BREAK) { + break; + } else if (result != TCL_OK) { + if (result == TCL_ERROR) { + Tcl_AddErrorInfo(interp, "\n (\"for\" loop-end command)"); + } + return result; + } + } + if (result == TCL_BREAK) { + result = TCL_OK; + } + if (result == TCL_OK) { + Tcl_ResetResult(interp); + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ForeachCmd -- + * + * This procedure is invoked to process the "foreach" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_ForeachCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int listArgc, i, result; + char **listArgv; + + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " varName list command\"", (char *) NULL); + return TCL_ERROR; + } + + /* + * Break the list up into elements, and execute the command once + * for each value of the element. + */ + + result = Tcl_SplitList(interp, argv[2], &listArgc, &listArgv); + if (result != TCL_OK) { + return result; + } + for (i = 0; i < listArgc; i++) { + if (Tcl_SetVar(interp, argv[1], listArgv[i], 0) == NULL) { + Tcl_SetResult(interp, "couldn't set loop variable", TCL_STATIC); + result = TCL_ERROR; + break; + } + + result = Tcl_Eval(interp, argv[3]); + if (result != TCL_OK) { + if (result == TCL_CONTINUE) { + result = TCL_OK; + } else if (result == TCL_BREAK) { + result = TCL_OK; + break; + } else if (result == TCL_ERROR) { + char msg[100]; + sprintf(msg, "\n (\"foreach\" body line %d)", + interp->errorLine); + Tcl_AddErrorInfo(interp, msg); + break; + } else { + break; + } + } + } + ckfree((char *) listArgv); + if (result == TCL_OK) { + Tcl_ResetResult(interp); + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_FormatCmd -- + * + * This procedure is invoked to process the "format" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_FormatCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + register char *format; /* Used to read characters from the format + * string. */ + char newFormat[40]; /* A new format specifier is generated here. */ + int width; /* Field width from field specifier, or 0 if + * no width given. */ + int precision; /* Field precision from field specifier, or 0 + * if no precision given. */ + int size; /* Number of bytes needed for result of + * conversion, based on type of conversion + * ("e", "s", etc.) and width from above. */ + char *oneWordValue = NULL; /* Used to hold value to pass to sprintf, if + * it's a one-word value. */ + double twoWordValue; /* Used to hold value to pass to sprintf if + * it's a two-word value. */ + int useTwoWords; /* 0 means use oneWordValue, 1 means use + * twoWordValue. */ + char *dst = interp->result; /* Where result is stored. Starts off at + * interp->resultSpace, but may get dynamically + * re-allocated if this isn't enough. */ + int dstSize = 0; /* Number of non-null characters currently + * stored at dst. */ + int dstSpace = TCL_RESULT_SIZE; + /* Total amount of storage space available + * in dst (not including null terminator. */ + int noPercent; /* Special case for speed: indicates there's + * no field specifier, just a string to copy. */ + int argIndex; /* Index of argument to substitute next. */ + int gotXpg = 0; /* Non-zero means that an XPG3 %n$-style + * specifier has been seen. */ + int gotSequential = 0; /* Non-zero means that a regular sequential + * (non-XPG3) conversion specifier has been + * seen. */ + int useShort; /* Value to be printed is short (half word). */ + char *end; /* Used to locate end of numerical fields. */ + + /* + * This procedure is a bit nasty. The goal is to use sprintf to + * do most of the dirty work. There are several problems: + * 1. this procedure can't trust its arguments. + * 2. we must be able to provide a large enough result area to hold + * whatever's generated. This is hard to estimate. + * 2. there's no way to move the arguments from argv to the call + * to sprintf in a reasonable way. This is particularly nasty + * because some of the arguments may be two-word values (doubles). + * So, what happens here is to scan the format string one % group + * at a time, making many individual calls to sprintf. + */ + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " formatString ?arg arg ...?\"", (char *) NULL); + return TCL_ERROR; + } + argIndex = 2; + for (format = argv[1]; *format != 0; ) { + register char *newPtr = newFormat; + + width = precision = useTwoWords = noPercent = useShort = 0; + + /* + * Get rid of any characters before the next field specifier. + */ + + if (*format != '%') { + register char *p; + + oneWordValue = p = format; + while ((*format != '%') && (*format != 0)) { + *p = *format; + p++; + format++; + } + size = p - oneWordValue; + noPercent = 1; + goto doField; + } + + if (format[1] == '%') { + oneWordValue = format; + size = 1; + noPercent = 1; + format += 2; + goto doField; + } + + /* + * Parse off a field specifier, compute how many characters + * will be needed to store the result, and substitute for + * "*" size specifiers. + */ + + *newPtr = '%'; + newPtr++; + format++; + if (isdigit(UCHAR(*format))) { + int tmp; + + /* + * Check for an XPG3-style %n$ specification. Note: there + * must not be a mixture of XPG3 specs and non-XPG3 specs + * in the same format string. + */ + + tmp = strtoul(format, &end, 10); + if (*end != '$') { + goto notXpg; + } + format = end+1; + gotXpg = 1; + if (gotSequential) { + goto mixedXPG; + } + argIndex = tmp+1; + if ((argIndex < 2) || (argIndex >= argc)) { + goto badIndex; + } + goto xpgCheckDone; + } + + notXpg: + gotSequential = 1; + if (gotXpg) { + goto mixedXPG; + } + + xpgCheckDone: + while ((*format == '-') || (*format == '#') || (*format == '0') + || (*format == ' ') || (*format == '+')) { + *newPtr = *format; + newPtr++; + format++; + } + if (isdigit(UCHAR(*format))) { + width = strtoul(format, &end, 10); + format = end; + } else if (*format == '*') { + if (argIndex >= argc) { + goto badIndex; + } + if (Tcl_GetInt(interp, argv[argIndex], &width) != TCL_OK) { + goto fmtError; + } + argIndex++; + format++; + } + if (width != 0) { + sprintf(newPtr, "%d", width); + while (*newPtr != 0) { + newPtr++; + } + } + if (*format == '.') { + *newPtr = '.'; + newPtr++; + format++; + } + if (isdigit(UCHAR(*format))) { + precision = strtoul(format, &end, 10); + format = end; + } else if (*format == '*') { + if (argIndex >= argc) { + goto badIndex; + } + if (Tcl_GetInt(interp, argv[argIndex], &precision) != TCL_OK) { + goto fmtError; + } + argIndex++; + format++; + } + if (precision != 0) { + sprintf(newPtr, "%d", precision); + while (*newPtr != 0) { + newPtr++; + } + } + if (*format == 'l') { + format++; + } else if (*format == 'h') { + useShort = 1; + *newPtr = 'h'; + newPtr++; + format++; + } + *newPtr = *format; + newPtr++; + *newPtr = 0; + if (argIndex >= argc) { + goto badIndex; + } + switch (*format) { + case 'i': + newPtr[-1] = 'd'; + case 'd': + case 'o': + case 'u': + case 'x': + case 'X': + if (Tcl_GetInt(interp, argv[argIndex], (int *) &oneWordValue) + != TCL_OK) { + goto fmtError; + } + size = 40; + break; + case 's': + oneWordValue = argv[argIndex]; + size = strlen(argv[argIndex]); + break; + case 'c': + if (Tcl_GetInt(interp, argv[argIndex], (int *) &oneWordValue) + != TCL_OK) { + goto fmtError; + } + size = 1; + break; + case 'e': + case 'E': + case 'f': + case 'g': + case 'G': + if (Tcl_GetDouble(interp, argv[argIndex], &twoWordValue) + != TCL_OK) { + goto fmtError; + } + useTwoWords = 1; + size = 320; + if (precision > 10) { + size += precision; + } + break; + case 0: + interp->result = + "format string ended in middle of field specifier"; + goto fmtError; + default: + sprintf(interp->result, "bad field specifier \"%c\"", *format); + goto fmtError; + } + argIndex++; + format++; + + /* + * Make sure that there's enough space to hold the formatted + * result, then format it. + */ + + doField: + if (width > size) { + size = width; + } + if ((dstSize + size) > dstSpace) { + char *newDst; + int newSpace; + + newSpace = 2*(dstSize + size); + newDst = (char *) ckalloc((unsigned) newSpace+1); + if (dstSize != 0) { + memcpy((VOID *) newDst, (VOID *) dst, dstSize); + } + if (dstSpace != TCL_RESULT_SIZE) { + ckfree(dst); + } + dst = newDst; + dstSpace = newSpace; + } + if (noPercent) { + memcpy((VOID *) (dst+dstSize), (VOID *) oneWordValue, size); + dstSize += size; + dst[dstSize] = 0; + } else { + if (useTwoWords) { + sprintf(dst+dstSize, newFormat, twoWordValue); + } else if (useShort) { + /* + * The double cast below is needed for a few machines + * (e.g. Pyramids as of 1/93) that don't like casts + * directly from pointers to shorts. + */ + + sprintf(dst+dstSize, newFormat, (short) (int) oneWordValue); + } else { + sprintf(dst+dstSize, newFormat, (char *) oneWordValue); + } + dstSize += strlen(dst+dstSize); + } + } + + interp->result = dst; + if (dstSpace != TCL_RESULT_SIZE) { + interp->freeProc = (Tcl_FreeProc *) free; + } else { + interp->freeProc = 0; + } + return TCL_OK; + + mixedXPG: + interp->result = "cannot mix \"%\" and \"%n$\" conversion specifiers"; + goto fmtError; + + badIndex: + if (gotXpg) { + interp->result = "\"%n$\" argument index out of range"; + } else { + interp->result = "not enough arguments for all format specifiers"; + } + + fmtError: + if (dstSpace != TCL_RESULT_SIZE) { + ckfree(dst); + } + return TCL_ERROR; +} diff --git a/vendor/x11iraf/obm/Tcl/tclCmdIL.c b/vendor/x11iraf/obm/Tcl/tclCmdIL.c new file mode 100644 index 00000000..d32e0f1e --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/tclCmdIL.c @@ -0,0 +1,1403 @@ +/* + * tclCmdIL.c -- + * + * This file contains the top-level command routines for most of + * the Tcl built-in commands whose names begin with the letters + * I through L. It contains only commands in the generic core + * (i.e. those that don't depend much upon UNIX facilities). + * + * Copyright (c) 1987-1993 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. + */ + +#ifndef lint +static char rcsid[] = "$Header: /user6/ouster/tcl/RCS/tclCmdIL.c,v 1.103 93/10/28 16:19:29 ouster Exp $ SPRITE (Berkeley)"; +#endif + +#include "tclInt.h" +#include "patchlevel.h" + +/* + * The variables below are used to implement the "lsort" command. + * Unfortunately, this use of static variables prevents "lsort" + * from being thread-safe, but there's no alternative given the + * current implementation of qsort. In a threaded environment + * these variables should be made thread-local if possible, or else + * "lsort" needs internal mutual exclusion. + */ + +static Tcl_Interp *sortInterp; /* Interpreter for "lsort" command. */ +static enum {ASCII, INTEGER, REAL, COMMAND} sortMode; + /* Mode for sorting: compare as strings, + * compare as numbers, or call + * user-defined command for + * comparison. */ +static Tcl_DString sortCmd; /* Holds command if mode is COMMAND. + * pre-initialized to hold base of + * command. */ +static int sortIncreasing; /* 0 means sort in decreasing order, + * 1 means increasing order. */ +static int sortCode; /* Anything other than TCL_OK means a + * problem occurred while sorting; this + * executing a comparison command, so + * the sort was aborted. */ + +/* + * Forward declarations for procedures defined in this file: + */ + +static int SortCompareProc _ANSI_ARGS_((CONST VOID *first, + CONST VOID *second)); + +/* + *---------------------------------------------------------------------- + * + * Tcl_IfCmd -- + * + * This procedure is invoked to process the "if" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_IfCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int i, result, value; + + i = 1; + while (1) { + /* + * At this point in the loop, argv and argc refer to an expression + * to test, either for the main expression or an expression + * following an "elseif". The arguments after the expression must + * be "then" (optional) and a script to execute if the expression is + * true. + */ + + if (i >= argc) { + Tcl_AppendResult(interp, "wrong # args: no expression after \"", + argv[i-1], "\" argument", (char *) NULL); + return TCL_ERROR; + } + result = Tcl_ExprBoolean(interp, argv[i], &value); + if (result != TCL_OK) { + return result; + } + i++; + if ((i < argc) && (strcmp(argv[i], "then") == 0)) { + i++; + } + if (i >= argc) { + Tcl_AppendResult(interp, "wrong # args: no script following \"", + argv[i-1], "\" argument", (char *) NULL); + return TCL_ERROR; + } + if (value) { + return Tcl_Eval(interp, argv[i]); + } + + /* + * The expression evaluated to false. Skip the command, then + * see if there is an "else" or "elseif" clause. + */ + + i++; + if (i >= argc) { + return TCL_OK; + } + if ((argv[i][0] == 'e') && (strcmp(argv[i], "elseif") == 0)) { + i++; + continue; + } + break; + } + + /* + * Couldn't find a "then" or "elseif" clause to execute. Check now + * for an "else" clause. We know that there's at least one more + * argument when we get here. + */ + + if (strcmp(argv[i], "else") == 0) { + i++; + if (i >= argc) { + Tcl_AppendResult(interp, + "wrong # args: no script following \"else\" argument", + (char *) NULL); + return TCL_ERROR; + } + } + return Tcl_Eval(interp, argv[i]); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_IncrCmd -- + * + * This procedure is invoked to process the "incr" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_IncrCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int value; + char *oldString, *result; + char newString[30]; + + if ((argc != 2) && (argc != 3)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " varName ?increment?\"", (char *) NULL); + return TCL_ERROR; + } + + oldString = Tcl_GetVar(interp, argv[1], TCL_LEAVE_ERR_MSG); + if (oldString == NULL) { + return TCL_ERROR; + } + if (Tcl_GetInt(interp, oldString, &value) != TCL_OK) { + Tcl_AddErrorInfo(interp, + "\n (reading value of variable to increment)"); + return TCL_ERROR; + } + if (argc == 2) { + value += 1; + } else { + int increment; + + if (Tcl_GetInt(interp, argv[2], &increment) != TCL_OK) { + Tcl_AddErrorInfo(interp, + "\n (reading increment)"); + return TCL_ERROR; + } + value += increment; + } + sprintf(newString, "%d", value); + result = Tcl_SetVar(interp, argv[1], newString, TCL_LEAVE_ERR_MSG); + if (result == NULL) { + return TCL_ERROR; + } + interp->result = result; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_InfoCmd -- + * + * This procedure is invoked to process the "info" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_InfoCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + register Interp *iPtr = (Interp *) interp; + int length; + char c; + Arg *argPtr; + Proc *procPtr; + Var *varPtr; + Command *cmdPtr; + Tcl_HashEntry *hPtr; + Tcl_HashSearch search; + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " option ?arg arg ...?\"", (char *) NULL); + return TCL_ERROR; + } + c = argv[1][0]; + length = strlen(argv[1]); + if ((c == 'a') && (strncmp(argv[1], "args", length)) == 0) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " args procname\"", (char *) NULL); + return TCL_ERROR; + } + procPtr = TclFindProc(iPtr, argv[2]); + if (procPtr == NULL) { + infoNoSuchProc: + Tcl_AppendResult(interp, "\"", argv[2], + "\" isn't a procedure", (char *) NULL); + return TCL_ERROR; + } + for (argPtr = procPtr->argPtr; argPtr != NULL; + argPtr = argPtr->nextPtr) { + Tcl_AppendElement(interp, argPtr->name); + } + return TCL_OK; + } else if ((c == 'b') && (strncmp(argv[1], "body", length)) == 0) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " body procname\"", (char *) NULL); + return TCL_ERROR; + } + procPtr = TclFindProc(iPtr, argv[2]); + if (procPtr == NULL) { + goto infoNoSuchProc; + } + iPtr->result = procPtr->command; + return TCL_OK; + } else if ((c == 'c') && (strncmp(argv[1], "cmdcount", length) == 0) + && (length >= 2)) { + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " cmdcount\"", (char *) NULL); + return TCL_ERROR; + } + sprintf(iPtr->result, "%d", iPtr->cmdCount); + return TCL_OK; + } else if ((c == 'c') && (strncmp(argv[1], "commands", length) == 0) + && (length >= 4)) { + if (argc > 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " commands [pattern]\"", (char *) NULL); + return TCL_ERROR; + } + for (hPtr = Tcl_FirstHashEntry(&iPtr->commandTable, &search); + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + char *name = Tcl_GetHashKey(&iPtr->commandTable, hPtr); + if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) { + continue; + } + Tcl_AppendElement(interp, name); + } + return TCL_OK; + } else if ((c == 'c') && (strncmp(argv[1], "complete", length) == 0) + && (length >= 4)) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " complete command\"", (char *) NULL); + return TCL_ERROR; + } + if (Tcl_CommandComplete(argv[2])) { + interp->result = "1"; + } else { + interp->result = "0"; + } + return TCL_OK; + } else if ((c == 'd') && (strncmp(argv[1], "default", length)) == 0) { + if (argc != 5) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " default procname arg varname\"", + (char *) NULL); + return TCL_ERROR; + } + procPtr = TclFindProc(iPtr, argv[2]); + if (procPtr == NULL) { + goto infoNoSuchProc; + } + for (argPtr = procPtr->argPtr; ; argPtr = argPtr->nextPtr) { + if (argPtr == NULL) { + Tcl_AppendResult(interp, "procedure \"", argv[2], + "\" doesn't have an argument \"", argv[3], + "\"", (char *) NULL); + return TCL_ERROR; + } + if (strcmp(argv[3], argPtr->name) == 0) { + if (argPtr->defValue != NULL) { + if (Tcl_SetVar((Tcl_Interp *) iPtr, argv[4], + argPtr->defValue, 0) == NULL) { + defStoreError: + Tcl_AppendResult(interp, + "couldn't store default value in variable \"", + argv[4], "\"", (char *) NULL); + return TCL_ERROR; + } + iPtr->result = "1"; + } else { + if (Tcl_SetVar((Tcl_Interp *) iPtr, argv[4], "", 0) + == NULL) { + goto defStoreError; + } + iPtr->result = "0"; + } + return TCL_OK; + } + } + } else if ((c == 'e') && (strncmp(argv[1], "exists", length) == 0)) { + char *p; + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " exists varName\"", (char *) NULL); + return TCL_ERROR; + } + p = Tcl_GetVar((Tcl_Interp *) iPtr, argv[2], 0); + + /* + * The code below handles the special case where the name is for + * an array: Tcl_GetVar will reject this since you can't read + * an array variable without an index. + */ + + if (p == NULL) { + Tcl_HashEntry *hPtr; + Var *varPtr; + + if (strchr(argv[2], '(') != NULL) { + noVar: + iPtr->result = "0"; + return TCL_OK; + } + if (iPtr->varFramePtr == NULL) { + hPtr = Tcl_FindHashEntry(&iPtr->globalTable, argv[2]); + } else { + hPtr = Tcl_FindHashEntry(&iPtr->varFramePtr->varTable, argv[2]); + } + if (hPtr == NULL) { + goto noVar; + } + varPtr = (Var *) Tcl_GetHashValue(hPtr); + if (varPtr->flags & VAR_UPVAR) { + varPtr = varPtr->value.upvarPtr; + } + if (!(varPtr->flags & VAR_ARRAY)) { + goto noVar; + } + } + iPtr->result = "1"; + return TCL_OK; + } else if ((c == 'g') && (strncmp(argv[1], "globals", length) == 0)) { + char *name; + + if (argc > 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " globals [pattern]\"", (char *) NULL); + return TCL_ERROR; + } + for (hPtr = Tcl_FirstHashEntry(&iPtr->globalTable, &search); + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + varPtr = (Var *) Tcl_GetHashValue(hPtr); + if (varPtr->flags & VAR_UNDEFINED) { + continue; + } + name = Tcl_GetHashKey(&iPtr->globalTable, hPtr); + if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) { + continue; + } + Tcl_AppendElement(interp, name); + } + return TCL_OK; + } else if ((c == 'l') && (strncmp(argv[1], "level", length) == 0) + && (length >= 2)) { + if (argc == 2) { + if (iPtr->varFramePtr == NULL) { + iPtr->result = "0"; + } else { + sprintf(iPtr->result, "%d", iPtr->varFramePtr->level); + } + return TCL_OK; + } else if (argc == 3) { + int level; + CallFrame *framePtr; + + if (Tcl_GetInt(interp, argv[2], &level) != TCL_OK) { + return TCL_ERROR; + } + if (level <= 0) { + if (iPtr->varFramePtr == NULL) { + levelError: + Tcl_AppendResult(interp, "bad level \"", argv[2], + "\"", (char *) NULL); + return TCL_ERROR; + } + level += iPtr->varFramePtr->level; + } + for (framePtr = iPtr->varFramePtr; framePtr != NULL; + framePtr = framePtr->callerVarPtr) { + if (framePtr->level == level) { + break; + } + } + if (framePtr == NULL) { + goto levelError; + } + iPtr->result = Tcl_Merge(framePtr->argc, framePtr->argv); + iPtr->freeProc = (Tcl_FreeProc *) free; + return TCL_OK; + } + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " level [number]\"", (char *) NULL); + return TCL_ERROR; + } else if ((c == 'l') && (strncmp(argv[1], "library", length) == 0) + && (length >= 2)) { + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " library\"", (char *) NULL); + return TCL_ERROR; + } + interp->result = getenv("TCL_LIBRARY"); + if (interp->result == NULL) { +#ifdef TCL_LIBRARY + interp->result = TCL_LIBRARY; +#else + interp->result = "there is no Tcl library at this installation"; + return TCL_ERROR; +#endif + } + return TCL_OK; + } else if ((c == 'l') && (strncmp(argv[1], "locals", length) == 0) + && (length >= 2)) { + char *name; + + if (argc > 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " locals [pattern]\"", (char *) NULL); + return TCL_ERROR; + } + if (iPtr->varFramePtr == NULL) { + return TCL_OK; + } + for (hPtr = Tcl_FirstHashEntry(&iPtr->varFramePtr->varTable, &search); + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + varPtr = (Var *) Tcl_GetHashValue(hPtr); + if (varPtr->flags & (VAR_UNDEFINED|VAR_UPVAR)) { + continue; + } + name = Tcl_GetHashKey(&iPtr->varFramePtr->varTable, hPtr); + if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) { + continue; + } + Tcl_AppendElement(interp, name); + } + return TCL_OK; + } else if ((c == 'p') && (strncmp(argv[1], "patchlevel", length) == 0) + && (length >= 2)) { + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " patchlevel\"", (char *) NULL); + return TCL_ERROR; + } + sprintf(interp->result, "%d", TCL_PATCH_LEVEL); + return TCL_OK; + } else if ((c == 'p') && (strncmp(argv[1], "procs", length) == 0) + && (length >= 2)) { + if (argc > 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " procs [pattern]\"", (char *) NULL); + return TCL_ERROR; + } + for (hPtr = Tcl_FirstHashEntry(&iPtr->commandTable, &search); + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + char *name = Tcl_GetHashKey(&iPtr->commandTable, hPtr); + + cmdPtr = (Command *) Tcl_GetHashValue(hPtr); + if (!TclIsProc(cmdPtr)) { + continue; + } + if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) { + continue; + } + Tcl_AppendElement(interp, name); + } + return TCL_OK; + } else if ((c == 's') && (strncmp(argv[1], "script", length) == 0)) { + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " script\"", (char *) NULL); + return TCL_ERROR; + } + if (iPtr->scriptFile != NULL) { + /* + * Can't depend on iPtr->scriptFile to be non-volatile: + * if this command is returned as the result of the script, + * then iPtr->scriptFile will go away. + */ + + Tcl_SetResult(interp, iPtr->scriptFile, TCL_VOLATILE); + } + return TCL_OK; + } else if ((c == 't') && (strncmp(argv[1], "tclversion", length) == 0)) { + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " tclversion\"", (char *) NULL); + return TCL_ERROR; + } + + /* + * Note: TCL_VERSION below is expected to be set with a "-D" + * switch in the Makefile. + */ + + strcpy(iPtr->result, TCL_VERSION); + return TCL_OK; + } else if ((c == 'v') && (strncmp(argv[1], "vars", length)) == 0) { + Tcl_HashTable *tablePtr; + char *name; + + if (argc > 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " vars [pattern]\"", (char *) NULL); + return TCL_ERROR; + } + if (iPtr->varFramePtr == NULL) { + tablePtr = &iPtr->globalTable; + } else { + tablePtr = &iPtr->varFramePtr->varTable; + } + for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + varPtr = (Var *) Tcl_GetHashValue(hPtr); + if (varPtr->flags & VAR_UNDEFINED) { + continue; + } + name = Tcl_GetHashKey(tablePtr, hPtr); + if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) { + continue; + } + Tcl_AppendElement(interp, name); + } + return TCL_OK; + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": should be args, body, cmdcount, commands, ", + "complete, default, ", + "exists, globals, level, library, locals, ", + "patchlevel, procs, script, tclversion, or vars", + (char *) NULL); + return TCL_ERROR; + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_JoinCmd -- + * + * This procedure is invoked to process the "join" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_JoinCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + char *joinString; + char **listArgv; + int listArgc, i; + + if (argc == 2) { + joinString = " "; + } else if (argc == 3) { + joinString = argv[2]; + } else { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " list ?joinString?\"", (char *) NULL); + return TCL_ERROR; + } + + if (Tcl_SplitList(interp, argv[1], &listArgc, &listArgv) != TCL_OK) { + return TCL_ERROR; + } + for (i = 0; i < listArgc; i++) { + if (i == 0) { + Tcl_AppendResult(interp, listArgv[0], (char *) NULL); + } else { + Tcl_AppendResult(interp, joinString, listArgv[i], (char *) NULL); + } + } + ckfree((char *) listArgv); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_LindexCmd -- + * + * This procedure is invoked to process the "lindex" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_LindexCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + char *p, *element; + int index, size, parenthesized, result; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " list index\"", (char *) NULL); + return TCL_ERROR; + } + if (Tcl_GetInt(interp, argv[2], &index) != TCL_OK) { + return TCL_ERROR; + } + if (index < 0) { + return TCL_OK; + } + for (p = argv[1] ; index >= 0; index--) { + result = TclFindElement(interp, p, &element, &p, &size, + &parenthesized); + if (result != TCL_OK) { + return result; + } + } + if (size == 0) { + return TCL_OK; + } + if (size >= TCL_RESULT_SIZE) { + interp->result = (char *) ckalloc((unsigned) size+1); + interp->freeProc = (Tcl_FreeProc *) free; + } + if (parenthesized) { + memcpy((VOID *) interp->result, (VOID *) element, size); + interp->result[size] = 0; + } else { + TclCopyAndCollapse(size, element, interp->result); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_LinsertCmd -- + * + * This procedure is invoked to process the "linsert" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_LinsertCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + char *p, *element, savedChar; + int i, index, count, result, size; + + if (argc < 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " list index element ?element ...?\"", (char *) NULL); + return TCL_ERROR; + } + if (Tcl_GetInt(interp, argv[2], &index) != TCL_OK) { + return TCL_ERROR; + } + + /* + * Skip over the first "index" elements of the list, then add + * all of those elements to the result. + */ + + size = 0; + element = argv[1]; + for (count = 0, p = argv[1]; (count < index) && (*p != 0); count++) { + result = TclFindElement(interp, p, &element, &p, &size, (int *) NULL); + if (result != TCL_OK) { + return result; + } + } + if (*p == 0) { + Tcl_AppendResult(interp, argv[1], (char *) NULL); + } else { + char *end; + + end = element+size; + if (element != argv[1]) { + while ((*end != 0) && !isspace(UCHAR(*end))) { + end++; + } + } + savedChar = *end; + *end = 0; + Tcl_AppendResult(interp, argv[1], (char *) NULL); + *end = savedChar; + } + + /* + * Add the new list elements. + */ + + for (i = 3; i < argc; i++) { + Tcl_AppendElement(interp, argv[i]); + } + + /* + * Append the remainder of the original list. + */ + + if (*p != 0) { + Tcl_AppendResult(interp, " ", p, (char *) NULL); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ListCmd -- + * + * This procedure is invoked to process the "list" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_ListCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + if (argc >= 2) { + interp->result = Tcl_Merge(argc-1, argv+1); + interp->freeProc = (Tcl_FreeProc *) free; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_LlengthCmd -- + * + * This procedure is invoked to process the "llength" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_LlengthCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int count, result; + char *element, *p; + + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " list\"", (char *) NULL); + return TCL_ERROR; + } + for (count = 0, p = argv[1]; *p != 0 ; count++) { + result = TclFindElement(interp, p, &element, &p, (int *) NULL, + (int *) NULL); + if (result != TCL_OK) { + return result; + } + if (*element == 0) { + break; + } + } + sprintf(interp->result, "%d", count); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_LrangeCmd -- + * + * This procedure is invoked to process the "lrange" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_LrangeCmd(notUsed, interp, argc, argv) + ClientData notUsed; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int first, last, result; + char *begin, *end, c, *dummy; + int count; + + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " list first last\"", (char *) NULL); + return TCL_ERROR; + } + if (Tcl_GetInt(interp, argv[2], &first) != TCL_OK) { + return TCL_ERROR; + } + if (first < 0) { + first = 0; + } + if ((*argv[3] == 'e') && (strncmp(argv[3], "end", strlen(argv[3])) == 0)) { + last = 1000000; + } else { + if (Tcl_GetInt(interp, argv[3], &last) != TCL_OK) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, + "expected integer or \"end\" but got \"", + argv[3], "\"", (char *) NULL); + return TCL_ERROR; + } + } + if (first > last) { + return TCL_OK; + } + + /* + * Extract a range of fields. + */ + + for (count = 0, begin = argv[1]; count < first; count++) { + result = TclFindElement(interp, begin, &dummy, &begin, (int *) NULL, + (int *) NULL); + if (result != TCL_OK) { + return result; + } + if (*begin == 0) { + break; + } + } + for (count = first, end = begin; (count <= last) && (*end != 0); + count++) { + result = TclFindElement(interp, end, &dummy, &end, (int *) NULL, + (int *) NULL); + if (result != TCL_OK) { + return result; + } + } + + /* + * Chop off trailing spaces. + */ + + while (isspace(UCHAR(end[-1]))) { + end--; + } + c = *end; + *end = 0; + Tcl_SetResult(interp, begin, TCL_VOLATILE); + *end = c; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_LreplaceCmd -- + * + * This procedure is invoked to process the "lreplace" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_LreplaceCmd(notUsed, interp, argc, argv) + ClientData notUsed; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + char *p1, *p2, *element, savedChar, *dummy; + int i, first, last, count, result, size; + + if (argc < 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " list first last ?element element ...?\"", (char *) NULL); + return TCL_ERROR; + } + if (Tcl_GetInt(interp, argv[2], &first) != TCL_OK) { + return TCL_ERROR; + } + if (TclGetListIndex(interp, argv[3], &last) != TCL_OK) { + return TCL_ERROR; + } + if (first < 0) { + first = 0; + } + if (last < 0) { + last = 0; + } + if (first > last) { + Tcl_AppendResult(interp, "first index must not be greater than second", + (char *) NULL); + return TCL_ERROR; + } + + /* + * Skip over the elements of the list before "first". + */ + + size = 0; + element = argv[1]; + for (count = 0, p1 = argv[1]; (count < first) && (*p1 != 0); count++) { + result = TclFindElement(interp, p1, &element, &p1, &size, + (int *) NULL); + if (result != TCL_OK) { + return result; + } + } + if (*p1 == 0) { + Tcl_AppendResult(interp, "list doesn't contain element ", + argv[2], (char *) NULL); + return TCL_ERROR; + } + + /* + * Skip over the elements of the list up through "last". + */ + + for (p2 = p1 ; (count <= last) && (*p2 != 0); count++) { + result = TclFindElement(interp, p2, &dummy, &p2, (int *) NULL, + (int *) NULL); + if (result != TCL_OK) { + return result; + } + } + + /* + * Add the elements before "first" to the result. Be sure to + * include quote or brace characters that might terminate the + * last of these elements. + */ + + p1 = element+size; + if (element != argv[1]) { + while ((*p1 != 0) && !isspace(UCHAR(*p1))) { + p1++; + } + } + savedChar = *p1; + *p1 = 0; + Tcl_AppendResult(interp, argv[1], (char *) NULL); + *p1 = savedChar; + + /* + * Add the new list elements. + */ + + for (i = 4; i < argc; i++) { + Tcl_AppendElement(interp, argv[i]); + } + + /* + * Append the remainder of the original list. + */ + + if (*p2 != 0) { + if (*interp->result == 0) { + Tcl_SetResult(interp, p2, TCL_VOLATILE); + } else { + Tcl_AppendResult(interp, " ", p2, (char *) NULL); + } + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_LsearchCmd -- + * + * This procedure is invoked to process the "lsearch" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_LsearchCmd(notUsed, interp, argc, argv) + ClientData notUsed; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ +#define EXACT 0 +#define GLOB 1 +#define REGEXP 2 + int listArgc; + char **listArgv; + int i, match, mode, index; + + mode = GLOB; + if (argc == 4) { + if (strcmp(argv[1], "-exact") == 0) { + mode = EXACT; + } else if (strcmp(argv[1], "-glob") == 0) { + mode = GLOB; + } else if (strcmp(argv[1], "-regexp") == 0) { + mode = REGEXP; + } else { + Tcl_AppendResult(interp, "bad search mode \"", argv[1], + "\": must be -exact, -glob, or -regexp", (char *) NULL); + return TCL_ERROR; + } + } else if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " ?mode? list pattern\"", (char *) NULL); + return TCL_ERROR; + } + if (Tcl_SplitList(interp, argv[argc-2], &listArgc, &listArgv) != TCL_OK) { + return TCL_ERROR; + } + index = -1; + for (i = 0; i < listArgc; i++) { + match = 0; + switch (mode) { + case EXACT: + match = (strcmp(listArgv[i], argv[argc-1]) == 0); + break; + case GLOB: + match = Tcl_StringMatch(listArgv[i], argv[argc-1]); + break; + case REGEXP: + match = Tcl_RegExpMatch(interp, listArgv[i], argv[argc-1]); + if (match < 0) { + ckfree((char *) listArgv); + return TCL_ERROR; + } + break; + } + if (match) { + index = i; + break; + } + } + sprintf(interp->result, "%d", index); + ckfree((char *) listArgv); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_LsortCmd -- + * + * This procedure is invoked to process the "lsort" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_LsortCmd(notUsed, interp, argc, argv) + ClientData notUsed; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int listArgc, i, c, length; + char **listArgv; + char *command = NULL; /* Initialization needed only to + * prevent compiler warning. */ + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " ?-ascii? ?-integer? ?-real? ?-increasing? ?-decreasing?", + " ?-command string? list\"", (char *) NULL); + return TCL_ERROR; + } + + /* + * Parse arguments to set up the mode for the sort. + */ + + sortInterp = interp; + sortMode = ASCII; + sortIncreasing = 1; + sortCode = TCL_OK; + for (i = 1; i < argc-1; i++) { + length = strlen(argv[i]); + if (length < 2) { + badSwitch: + Tcl_AppendResult(interp, "bad switch \"", argv[i], + "\": must be -ascii, -integer, -real, -increasing", + " -decreasing, or -command", (char *) NULL); + return TCL_ERROR; + } + c = argv[i][1]; + if ((c == 'a') && (strncmp(argv[i], "-ascii", length) == 0)) { + sortMode = ASCII; + } else if ((c == 'c') && (strncmp(argv[i], "-command", length) == 0)) { + if (i == argc-2) { + Tcl_AppendResult(interp, "\"-command\" must be", + " followed by comparison command", (char *) NULL); + return TCL_ERROR; + } + sortMode = COMMAND; + command = argv[i+1]; + i++; + } else if ((c == 'd') + && (strncmp(argv[i], "-decreasing", length) == 0)) { + sortIncreasing = 0; + } else if ((c == 'i') && (length >= 4) + && (strncmp(argv[i], "-increasing", length) == 0)) { + sortIncreasing = 1; + } else if ((c == 'i') && (length >= 4) + && (strncmp(argv[i], "-integer", length) == 0)) { + sortMode = INTEGER; + } else if ((c == 'r') + && (strncmp(argv[i], "-real", length) == 0)) { + sortMode = REAL; + } else { + goto badSwitch; + } + } + if (sortMode == COMMAND) { + Tcl_DStringInit(&sortCmd); + Tcl_DStringAppend(&sortCmd, command, -1); + } + + if (Tcl_SplitList(interp, argv[argc-1], &listArgc, &listArgv) != TCL_OK) { + return TCL_ERROR; + } + qsort((VOID *) listArgv, listArgc, sizeof (char *), SortCompareProc); + if (sortCode == TCL_OK) { + Tcl_ResetResult(interp); + interp->result = Tcl_Merge(listArgc, listArgv); + interp->freeProc = (Tcl_FreeProc *) free; + } + if (sortMode == COMMAND) { + Tcl_DStringFree(&sortCmd); + } + ckfree((char *) listArgv); + return sortCode; +} + +/* + *---------------------------------------------------------------------- + * + * SortCompareProc -- + * + * This procedure is invoked by qsort to determine the proper + * ordering between two elements. + * + * Results: + * < 0 means first is "smaller" than "second", > 0 means "first" + * is larger than "second", and 0 means they should be treated + * as equal. + * + * Side effects: + * None, unless a user-defined comparison command does something + * weird. + * + *---------------------------------------------------------------------- + */ + +static int +SortCompareProc(first, second) + CONST VOID *first, *second; /* Elements to be compared. */ +{ + int order; + char *firstString = *((char **) first); + char *secondString = *((char **) second); + + order = 0; + if (sortCode != TCL_OK) { + /* + * Once an error has occurred, skip any future comparisons + * so as to preserve the error message in sortInterp->result. + */ + + return order; + } + if (sortMode == ASCII) { + order = strcmp(firstString, secondString); + } else if (sortMode == INTEGER) { + int a, b; + + if ((Tcl_GetInt(sortInterp, firstString, &a) != TCL_OK) + || (Tcl_GetInt(sortInterp, secondString, &b) != TCL_OK)) { + Tcl_AddErrorInfo(sortInterp, + "\n (converting list element from string to integer)"); + sortCode = TCL_ERROR; + return order; + } + if (a > b) { + order = 1; + } else if (b > a) { + order = -1; + } + } else if (sortMode == REAL) { + double a, b; + + if ((Tcl_GetDouble(sortInterp, firstString, &a) != TCL_OK) + || (Tcl_GetDouble(sortInterp, secondString, &b) != TCL_OK)) { + Tcl_AddErrorInfo(sortInterp, + "\n (converting list element from string to real)"); + sortCode = TCL_ERROR; + return order; + } + if (a > b) { + order = 1; + } else if (b > a) { + order = -1; + } + } else { + int oldLength; + char *end; + + /* + * Generate and evaluate a command to determine which string comes + * first. + */ + + oldLength = Tcl_DStringLength(&sortCmd); + Tcl_DStringAppendElement(&sortCmd, firstString); + Tcl_DStringAppendElement(&sortCmd, secondString); + sortCode = Tcl_Eval(sortInterp, Tcl_DStringValue(&sortCmd)); + Tcl_DStringTrunc(&sortCmd, oldLength); + if (sortCode != TCL_OK) { + Tcl_AddErrorInfo(sortInterp, + "\n (user-defined comparison command)"); + return order; + } + + /* + * Parse the result of the command. + */ + + order = strtol(sortInterp->result, &end, 0); + if ((end == sortInterp->result) || (*end != 0)) { + Tcl_ResetResult(sortInterp); + Tcl_AppendResult(sortInterp, + "comparison command returned non-numeric result", + (char *) NULL); + sortCode = TCL_ERROR; + return order; + } + } + if (!sortIncreasing) { + order = -order; + } + return order; +} diff --git a/vendor/x11iraf/obm/Tcl/tclCmdMZ.c b/vendor/x11iraf/obm/Tcl/tclCmdMZ.c new file mode 100644 index 00000000..92f9340c --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/tclCmdMZ.c @@ -0,0 +1,1730 @@ +/* + * tclCmdMZ.c -- + * + * This file contains the top-level command routines for most of + * the Tcl built-in commands whose names begin with the letters + * M to Z. It contains only commands in the generic core (i.e. + * those that don't depend much upon UNIX facilities). + * + * Copyright (c) 1987-1993 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. + */ + +#ifndef lint +static char rcsid[] = "$Header: /user6/ouster/tcl/RCS/tclCmdMZ.c,v 1.44 93/10/15 11:41:16 ouster Exp $ SPRITE (Berkeley)"; +#endif + +#include "tclInt.h" + +/* + * Structure used to hold information about variable traces: + */ + +typedef struct { + int flags; /* Operations for which Tcl command is + * to be invoked. */ + char *errMsg; /* Error message returned from Tcl command, + * or NULL. Malloc'ed. */ + int length; /* Number of non-NULL chars. in command. */ + char command[4]; /* Space for Tcl command to invoke. Actual + * size will be as large as necessary to + * hold command. This field must be the + * last in the structure, so that it can + * be larger than 4 bytes. */ +} TraceVarInfo; + +/* + * Forward declarations for procedures defined in this file: + */ + +static char * TraceVarProc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, char *name1, char *name2, + int flags)); + +/* + *---------------------------------------------------------------------- + * + * Tcl_RegexpCmd -- + * + * This procedure is invoked to process the "regexp" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_RegexpCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int noCase = 0; + int indices = 0; + regexp *regexpPtr; + char **argPtr, *string, *pattern; + int match = 0; /* Initialization needed only to + * prevent compiler warning. */ + int i; + Tcl_DString stringDString, patternDString; + + if (argc < 3) { + wrongNumArgs: + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " ?switches? exp string ?matchVar? ?subMatchVar ", + "subMatchVar ...?\"", (char *) NULL); + return TCL_ERROR; + } + argPtr = argv+1; + argc--; + while ((argc > 0) && (argPtr[0][0] == '-')) { + if (strcmp(argPtr[0], "-indices") == 0) { + indices = 1; + } else if (strcmp(argPtr[0], "-nocase") == 0) { + noCase = 1; + } else if (strcmp(argPtr[0], "--") == 0) { + argPtr++; + argc--; + break; + } else { + Tcl_AppendResult(interp, "bad switch \"", argPtr[0], + "\": must be -indices, -nocase, or --", (char *) NULL); + return TCL_ERROR; + } + argPtr++; + argc--; + } + if (argc < 2) { + goto wrongNumArgs; + } + + /* + * Convert the string and pattern to lower case, if desired, and + * perform the matching operation. + */ + + if (noCase) { + register char *p; + + Tcl_DStringInit(&patternDString); + Tcl_DStringAppend(&patternDString, argPtr[0], -1); + pattern = Tcl_DStringValue(&patternDString); + for (p = pattern; *p != 0; p++) { + if (isupper(UCHAR(*p))) { + *p = tolower(*p); + } + } + Tcl_DStringInit(&stringDString); + Tcl_DStringAppend(&stringDString, argPtr[1], -1); + string = Tcl_DStringValue(&stringDString); + for (p = string; *p != 0; p++) { + if (isupper(UCHAR(*p))) { + *p = tolower(*p); + } + } + } else { + pattern = argPtr[0]; + string = argPtr[1]; + } + regexpPtr = TclCompileRegexp(interp, pattern); + if (regexpPtr != NULL) { + tclRegexpError = NULL; + match = TclRegExec(regexpPtr, string, string); + } + if (noCase) { + Tcl_DStringFree(&stringDString); + Tcl_DStringFree(&patternDString); + } + if (regexpPtr == NULL) { + return TCL_ERROR; + } + if (tclRegexpError != NULL) { + Tcl_AppendResult(interp, "error while matching pattern: ", + tclRegexpError, (char *) NULL); + return TCL_ERROR; + } + if (!match) { + interp->result = "0"; + return TCL_OK; + } + + /* + * If additional variable names have been specified, return + * index information in those variables. + */ + + argc -= 2; + if (argc > NSUBEXP) { + interp->result = "too many substring variables"; + return TCL_ERROR; + } + for (i = 0; i < argc; i++) { + char *result, info[50]; + + if (regexpPtr->startp[i] == NULL) { + if (indices) { + result = Tcl_SetVar(interp, argPtr[i+2], "-1 -1", 0); + } else { + result = Tcl_SetVar(interp, argPtr[i+2], "", 0); + } + } else { + if (indices) { + sprintf(info, "%d %d", regexpPtr->startp[i] - string, + regexpPtr->endp[i] - string - 1); + result = Tcl_SetVar(interp, argPtr[i+2], info, 0); + } else { + char savedChar, *first, *last; + + first = argPtr[1] + (regexpPtr->startp[i] - string); + last = argPtr[1] + (regexpPtr->endp[i] - string); + savedChar = *last; + *last = 0; + result = Tcl_SetVar(interp, argPtr[i+2], first, 0); + *last = savedChar; + } + } + if (result == NULL) { + Tcl_AppendResult(interp, "couldn't set variable \"", + argPtr[i+2], "\"", (char *) NULL); + return TCL_ERROR; + } + } + interp->result = "1"; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_RegsubCmd -- + * + * This procedure is invoked to process the "regsub" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_RegsubCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int noCase = 0, all = 0; + regexp *regexpPtr; + char *string, *pattern, *p, *firstChar, *newValue, **argPtr; + int match, flags, code, anyMatches; + register char *src, c; + Tcl_DString stringDString, patternDString; + + if (argc < 5) { + wrongNumArgs: + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " ?switches? exp string subSpec varName\"", (char *) NULL); + return TCL_ERROR; + } + argPtr = argv+1; + argc--; + while (argPtr[0][0] == '-') { + if (strcmp(argPtr[0], "-nocase") == 0) { + noCase = 1; + } else if (strcmp(argPtr[0], "-all") == 0) { + all = 1; + } else if (strcmp(argPtr[0], "--") == 0) { + argPtr++; + argc--; + break; + } else { + Tcl_AppendResult(interp, "bad switch \"", argPtr[0], + "\": must be -all, -nocase, or --", (char *) NULL); + return TCL_ERROR; + } + argPtr++; + argc--; + } + if (argc != 4) { + goto wrongNumArgs; + } + + /* + * Convert the string and pattern to lower case, if desired. + */ + + if (noCase) { + Tcl_DStringInit(&patternDString); + Tcl_DStringAppend(&patternDString, argPtr[0], -1); + pattern = Tcl_DStringValue(&patternDString); + for (p = pattern; *p != 0; p++) { + if (isupper(UCHAR(*p))) { + *p = tolower(*p); + } + } + Tcl_DStringInit(&stringDString); + Tcl_DStringAppend(&stringDString, argPtr[1], -1); + string = Tcl_DStringValue(&stringDString); + for (p = string; *p != 0; p++) { + if (isupper(UCHAR(*p))) { + *p = tolower(*p); + } + } + } else { + pattern = argPtr[0]; + string = argPtr[1]; + } + regexpPtr = TclCompileRegexp(interp, pattern); + if (regexpPtr == NULL) { + code = TCL_ERROR; + goto done; + } + + /* + * The following loop is to handle multiple matches within the + * same source string; each iteration handles one match and its + * corresponding substitution. If "-all" hasn't been specified + * then the loop body only gets executed once. + */ + + flags = 0; + anyMatches = 0; + for (p = string; *p != 0; ) { + tclRegexpError = NULL; + match = TclRegExec(regexpPtr, p, string); + if (tclRegexpError != NULL) { + Tcl_AppendResult(interp, "error while matching pattern: ", + tclRegexpError, (char *) NULL); + code = TCL_ERROR; + goto done; + } + if (!match) { + break; + } + anyMatches = 1; + + /* + * Copy the portion of the source string before the match to the + * result variable. + */ + + src = argPtr[1] + (regexpPtr->startp[0] - string); + c = *src; + *src = 0; + newValue = Tcl_SetVar(interp, argPtr[3], argPtr[1] + (p - string), + flags); + *src = c; + flags = TCL_APPEND_VALUE; + if (newValue == NULL) { + cantSet: + Tcl_AppendResult(interp, "couldn't set variable \"", + argPtr[3], "\"", (char *) NULL); + code = TCL_ERROR; + goto done; + } + + /* + * Append the subSpec argument to the variable, making appropriate + * substitutions. This code is a bit hairy because of the backslash + * conventions and because the code saves up ranges of characters in + * subSpec to reduce the number of calls to Tcl_SetVar. + */ + + for (src = firstChar = argPtr[2], c = *src; c != 0; src++, c = *src) { + int index; + + if (c == '&') { + index = 0; + } else if (c == '\\') { + c = src[1]; + if ((c >= '0') && (c <= '9')) { + index = c - '0'; + } else if ((c == '\\') || (c == '&')) { + *src = c; + src[1] = 0; + newValue = Tcl_SetVar(interp, argPtr[3], firstChar, + TCL_APPEND_VALUE); + *src = '\\'; + src[1] = c; + if (newValue == NULL) { + goto cantSet; + } + firstChar = src+2; + src++; + continue; + } else { + continue; + } + } else { + continue; + } + if (firstChar != src) { + c = *src; + *src = 0; + newValue = Tcl_SetVar(interp, argPtr[3], firstChar, + TCL_APPEND_VALUE); + *src = c; + if (newValue == NULL) { + goto cantSet; + } + } + if ((index < NSUBEXP) && (regexpPtr->startp[index] != NULL) + && (regexpPtr->endp[index] != NULL)) { + char *first, *last, saved; + + first = argPtr[1] + (regexpPtr->startp[index] - string); + last = argPtr[1] + (regexpPtr->endp[index] - string); + saved = *last; + *last = 0; + newValue = Tcl_SetVar(interp, argPtr[3], first, + TCL_APPEND_VALUE); + *last = saved; + if (newValue == NULL) { + goto cantSet; + } + } + if (*src == '\\') { + src++; + } + firstChar = src+1; + } + if (firstChar != src) { + if (Tcl_SetVar(interp, argPtr[3], firstChar, + TCL_APPEND_VALUE) == NULL) { + goto cantSet; + } + } + if (regexpPtr->endp[0] == p) { + char tmp[2]; + + /* + * Always consume at least one character of the input string + * in order to prevent infinite loops. + */ + + tmp[0] = argPtr[1][p - string]; + tmp[1] = 0; + newValue = Tcl_SetVar(interp, argPtr[3], tmp, flags); + if (newValue == NULL) { + goto cantSet; + } + p = regexpPtr->endp[0] + 1; + } else { + p = regexpPtr->endp[0]; + } + if (!all) { + break; + } + } + + /* + * Copy the portion of the source string after the last match to the + * result variable. + */ + + if ((*p != 0) || !anyMatches) { + if (Tcl_SetVar(interp, argPtr[3], argPtr[1] + (p - string), + flags) == NULL) { + goto cantSet; + } + } + if (anyMatches) { + interp->result = "1"; + } else { + interp->result = "0"; + } + code = TCL_OK; + + done: + if (noCase) { + Tcl_DStringFree(&stringDString); + Tcl_DStringFree(&patternDString); + } + return code; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_RenameCmd -- + * + * This procedure is invoked to process the "rename" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_RenameCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + register Command *cmdPtr; + Interp *iPtr = (Interp *) interp; + Tcl_HashEntry *hPtr; + int new; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " oldName newName\"", (char *) NULL); + return TCL_ERROR; + } + if (argv[2][0] == '\0') { + if (Tcl_DeleteCommand(interp, argv[1]) != 0) { + Tcl_AppendResult(interp, "can't delete \"", argv[1], + "\": command doesn't exist", (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; + } + hPtr = Tcl_FindHashEntry(&iPtr->commandTable, argv[2]); + if (hPtr != NULL) { + Tcl_AppendResult(interp, "can't rename to \"", argv[2], + "\": command already exists", (char *) NULL); + return TCL_ERROR; + } + hPtr = Tcl_FindHashEntry(&iPtr->commandTable, argv[1]); + if (hPtr == NULL) { + Tcl_AppendResult(interp, "can't rename \"", argv[1], + "\": command doesn't exist", (char *) NULL); + return TCL_ERROR; + } + cmdPtr = (Command *) Tcl_GetHashValue(hPtr); + Tcl_DeleteHashEntry(hPtr); + hPtr = Tcl_CreateHashEntry(&iPtr->commandTable, argv[2], &new); + Tcl_SetHashValue(hPtr, cmdPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ReturnCmd -- + * + * This procedure is invoked to process the "return" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_ReturnCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Interp *iPtr = (Interp *) interp; + int c, code; + + if (iPtr->errorInfo != NULL) { + ckfree(iPtr->errorInfo); + iPtr->errorInfo = NULL; + } + if (iPtr->errorCode != NULL) { + ckfree(iPtr->errorCode); + iPtr->errorCode = NULL; + } + code = TCL_OK; + for (argv++, argc--; argc > 1; argv += 2, argc -= 2) { + if (strcmp(argv[0], "-code") == 0) { + c = argv[1][0]; + if ((c == 'o') && (strcmp(argv[1], "ok") == 0)) { + code = TCL_OK; + } else if ((c == 'e') && (strcmp(argv[1], "error") == 0)) { + code = TCL_ERROR; + } else if ((c == 'r') && (strcmp(argv[1], "return") == 0)) { + code = TCL_RETURN; + } else if ((c == 'b') && (strcmp(argv[1], "break") == 0)) { + code = TCL_BREAK; + } else if ((c == 'c') && (strcmp(argv[1], "continue") == 0)) { + code = TCL_CONTINUE; + } else if (Tcl_GetInt(interp, argv[1], &code) != TCL_OK) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "bad completion code \"", + argv[1], "\": must be ok, error, return, break, ", + "continue, or an integer", (char *) NULL); + return TCL_ERROR; + } + } else if (strcmp(argv[0], "-errorinfo") == 0) { + iPtr->errorInfo = ckalloc((unsigned) (strlen(argv[1]) + 1)); + strcpy(iPtr->errorInfo, argv[1]); + } else if (strcmp(argv[0], "-errorcode") == 0) { + iPtr->errorCode = ckalloc((unsigned) (strlen(argv[1]) + 1)); + strcpy(iPtr->errorCode, argv[1]); + } else { + Tcl_AppendResult(interp, "bad option \"", argv[0], + ": must be -code, -errorcode, or -errorinfo", + (char *) NULL); + return TCL_ERROR; + } + } + if (argc == 1) { + Tcl_SetResult(interp, argv[0], TCL_VOLATILE); + } + iPtr->returnCode = code; + return TCL_RETURN; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ScanCmd -- + * + * This procedure is invoked to process the "scan" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_ScanCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ +# define MAX_FIELDS 20 + typedef struct { + char fmt; /* Format for field. */ + int size; /* How many bytes to allow for + * field. */ + char *location; /* Where field will be stored. */ + } Field; + Field fields[MAX_FIELDS]; /* Info about all the fields in the + * format string. */ + register Field *curField; + int numFields = 0; /* Number of fields actually + * specified. */ + int suppress; /* Current field is assignment- + * suppressed. */ + int totalSize = 0; /* Number of bytes needed to store + * all results combined. */ + char *results; /* Where scanned output goes. + * Malloced; NULL means not allocated + * yet. */ + int numScanned; /* sscanf's result. */ + register char *fmt; + int i, widthSpecified, length, code; + + /* + * The variables below are used to hold a copy of the format + * string, so that we can replace format specifiers like "%f" + * and "%F" with specifiers like "%lf" + */ + +# define STATIC_SIZE 5 + char copyBuf[STATIC_SIZE], *fmtCopy; + register char *dst; + + if (argc < 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " string format ?varName varName ...?\"", (char *) NULL); + return TCL_ERROR; + } + + /* + * This procedure operates in four stages: + * 1. Scan the format string, collecting information about each field. + * 2. Allocate an array to hold all of the scanned fields. + * 3. Call sscanf to do all the dirty work, and have it store the + * parsed fields in the array. + * 4. Pick off the fields from the array and assign them to variables. + */ + + code = TCL_OK; + results = NULL; + length = strlen(argv[2]) * 2 + 1; + if (length < STATIC_SIZE) { + fmtCopy = copyBuf; + } else { + fmtCopy = ckalloc((unsigned) length); + } + dst = fmtCopy; + for (fmt = argv[2]; *fmt != 0; fmt++) { + *dst = *fmt; + dst++; + if (*fmt != '%') { + continue; + } + fmt++; + if (*fmt == '%') { + *dst = *fmt; + dst++; + continue; + } + if (*fmt == '*') { + suppress = 1; + *dst = *fmt; + dst++; + fmt++; + } else { + suppress = 0; + } + widthSpecified = 0; + while (isdigit(UCHAR(*fmt))) { + widthSpecified = 1; + *dst = *fmt; + dst++; + fmt++; + } + if ((*fmt == 'l') || (*fmt == 'h') || (*fmt == 'L')) { + fmt++; + } + *dst = *fmt; + dst++; + if (suppress) { + continue; + } + if (numFields == MAX_FIELDS) { + interp->result = "too many fields to scan"; + code = TCL_ERROR; + goto done; + } + curField = &fields[numFields]; + numFields++; + switch (*fmt) { + case 'd': + case 'i': + case 'o': + case 'x': + curField->fmt = 'd'; + curField->size = sizeof(int); + break; + + case 'u': + curField->fmt = 'u'; + curField->size = sizeof(int); + break; + + case 's': + curField->fmt = 's'; + curField->size = strlen(argv[1]) + 1; + break; + + case 'c': + if (widthSpecified) { + interp->result = + "field width may not be specified in %c conversion"; + code = TCL_ERROR; + goto done; + } + curField->fmt = 'c'; + curField->size = sizeof(int); + break; + + case 'e': + case 'f': + case 'g': + dst[-1] = 'l'; + dst[0] = 'f'; + dst++; + curField->fmt = 'f'; + curField->size = sizeof(double); + break; + + case '[': + curField->fmt = 's'; + curField->size = strlen(argv[1]) + 1; + do { + fmt++; + *dst = *fmt; + dst++; + } while (*fmt != ']'); + break; + + default: + sprintf(interp->result, "bad scan conversion character \"%c\"", + *fmt); + code = TCL_ERROR; + goto done; + } + curField->size = TCL_ALIGN(curField->size); + totalSize += curField->size; + } + *dst = 0; + + if (numFields != (argc-3)) { + interp->result = + "different numbers of variable names and field specifiers"; + code = TCL_ERROR; + goto done; + } + + /* + * Step 2: + */ + + results = (char *) ckalloc((unsigned) totalSize); + for (i = 0, totalSize = 0, curField = fields; + i < numFields; i++, curField++) { + curField->location = results + totalSize; + totalSize += curField->size; + } + + /* + * Fill in the remaining fields with NULL; the only purpose of + * this is to keep some memory analyzers, like Purify, from + * complaining. + */ + + for ( ; i < MAX_FIELDS; i++, curField++) { + curField->location = NULL; + } + + /* + * Step 3: + */ + + numScanned = sscanf(argv[1], fmtCopy, + fields[0].location, fields[1].location, fields[2].location, + fields[3].location, fields[4].location, fields[5].location, + fields[6].location, fields[7].location, fields[8].location, + fields[9].location, fields[10].location, fields[11].location, + fields[12].location, fields[13].location, fields[14].location, + fields[15].location, fields[16].location, fields[17].location, + fields[18].location, fields[19].location); + + /* + * Step 4: + */ + + if (numScanned < numFields) { + numFields = numScanned; + } + for (i = 0, curField = fields; i < numFields; i++, curField++) { + switch (curField->fmt) { + char string[TCL_DOUBLE_SPACE]; + + case 'd': + sprintf(string, "%d", *((int *) curField->location)); + if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) { + storeError: + Tcl_AppendResult(interp, + "couldn't set variable \"", argv[i+3], "\"", + (char *) NULL); + code = TCL_ERROR; + goto done; + } + break; + + case 'u': + sprintf(string, "%u", *((int *) curField->location)); + if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) { + goto storeError; + } + break; + + case 'c': + sprintf(string, "%d", *((char *) curField->location) & 0xff); + if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) { + goto storeError; + } + break; + + case 's': + if (Tcl_SetVar(interp, argv[i+3], curField->location, 0) + == NULL) { + goto storeError; + } + break; + + case 'f': + Tcl_PrintDouble(interp, *((double *) curField->location), + string); + if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) { + goto storeError; + } + break; + } + } + sprintf(interp->result, "%d", numScanned); + done: + if (results != NULL) { + ckfree(results); + } + if (fmtCopy != copyBuf) { + ckfree(fmtCopy); + } + return code; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SplitCmd -- + * + * This procedure is invoked to process the "split" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_SplitCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + char *splitChars; + register char *p, *p2; + char *elementStart; + + if (argc == 2) { + splitChars = " \n\t\r"; + } else if (argc == 3) { + splitChars = argv[2]; + } else { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " string ?splitChars?\"", (char *) NULL); + return TCL_ERROR; + } + + /* + * Handle the special case of splitting on every character. + */ + + if (*splitChars == 0) { + char string[2]; + string[1] = 0; + for (p = argv[1]; *p != 0; p++) { + string[0] = *p; + Tcl_AppendElement(interp, string); + } + return TCL_OK; + } + + /* + * Normal case: split on any of a given set of characters. + * Discard instances of the split characters. + */ + + for (p = elementStart = argv[1]; *p != 0; p++) { + char c = *p; + for (p2 = splitChars; *p2 != 0; p2++) { + if (*p2 == c) { + *p = 0; + Tcl_AppendElement(interp, elementStart); + *p = c; + elementStart = p+1; + break; + } + } + } + if (p != argv[1]) { + Tcl_AppendElement(interp, elementStart); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_StringCmd -- + * + * This procedure is invoked to process the "string" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_StringCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int length; + register char *p, c; + int match; + int first; + int left = 0, right = 0; + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " option arg ?arg ...?\"", (char *) NULL); + return TCL_ERROR; + } + c = argv[1][0]; + length = strlen(argv[1]); + if ((c == 'c') && (strncmp(argv[1], "compare", length) == 0)) { + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " compare string1 string2\"", (char *) NULL); + return TCL_ERROR; + } + match = strcmp(argv[2], argv[3]); + if (match > 0) { + interp->result = "1"; + } else if (match < 0) { + interp->result = "-1"; + } else { + interp->result = "0"; + } + return TCL_OK; + } else if ((c == 'f') && (strncmp(argv[1], "first", length) == 0)) { + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " first string1 string2\"", (char *) NULL); + return TCL_ERROR; + } + first = 1; + + firstLast: + match = -1; + c = *argv[2]; + length = strlen(argv[2]); + for (p = argv[3]; *p != 0; p++) { + if (*p != c) { + continue; + } + if (strncmp(argv[2], p, length) == 0) { + match = p-argv[3]; + if (first) { + break; + } + } + } + sprintf(interp->result, "%d", match); + return TCL_OK; + } else if ((c == 'i') && (strncmp(argv[1], "index", length) == 0)) { + int index; + + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " index string charIndex\"", (char *) NULL); + return TCL_ERROR; + } + if (Tcl_GetInt(interp, argv[3], &index) != TCL_OK) { + return TCL_ERROR; + } + if ((index >= 0) && (index < (int) strlen(argv[2]))) { + interp->result[0] = argv[2][index]; + interp->result[1] = 0; + } + return TCL_OK; + } else if ((c == 'l') && (strncmp(argv[1], "last", length) == 0) + && (length >= 2)) { + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " last string1 string2\"", (char *) NULL); + return TCL_ERROR; + } + first = 0; + goto firstLast; + } else if ((c == 'l') && (strncmp(argv[1], "length", length) == 0) + && (length >= 2)) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " length string\"", (char *) NULL); + return TCL_ERROR; + } + sprintf(interp->result, "%d", strlen(argv[2])); + return TCL_OK; + } else if ((c == 'm') && (strncmp(argv[1], "match", length) == 0)) { + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " match pattern string\"", (char *) NULL); + return TCL_ERROR; + } + if (Tcl_StringMatch(argv[3], argv[2]) != 0) { + interp->result = "1"; + } else { + interp->result = "0"; + } + return TCL_OK; + } else if ((c == 'r') && (strncmp(argv[1], "range", length) == 0)) { + int first, last, stringLength; + + if (argc != 5) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " range string first last\"", (char *) NULL); + return TCL_ERROR; + } + stringLength = strlen(argv[2]); + if (Tcl_GetInt(interp, argv[3], &first) != TCL_OK) { + return TCL_ERROR; + } + if ((*argv[4] == 'e') + && (strncmp(argv[4], "end", strlen(argv[4])) == 0)) { + last = stringLength-1; + } else { + if (Tcl_GetInt(interp, argv[4], &last) != TCL_OK) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, + "expected integer or \"end\" but got \"", + argv[4], "\"", (char *) NULL); + return TCL_ERROR; + } + } + if (first < 0) { + first = 0; + } + if (last >= stringLength) { + last = stringLength-1; + } + if (last >= first) { + char saved, *p; + + p = argv[2] + last + 1; + saved = *p; + *p = 0; + Tcl_SetResult(interp, argv[2] + first, TCL_VOLATILE); + *p = saved; + } + return TCL_OK; + } else if ((c == 't') && (strncmp(argv[1], "tolower", length) == 0) + && (length >= 3)) { + register char *p; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " tolower string\"", (char *) NULL); + return TCL_ERROR; + } + Tcl_SetResult(interp, argv[2], TCL_VOLATILE); + for (p = interp->result; *p != 0; p++) { + if (isupper(UCHAR(*p))) { + *p = tolower(*p); + } + } + return TCL_OK; + } else if ((c == 't') && (strncmp(argv[1], "toupper", length) == 0) + && (length >= 3)) { + register char *p; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " toupper string\"", (char *) NULL); + return TCL_ERROR; + } + Tcl_SetResult(interp, argv[2], TCL_VOLATILE); + for (p = interp->result; *p != 0; p++) { + if (islower(UCHAR(*p))) { + *p = toupper(*p); + } + } + return TCL_OK; + } else if ((c == 't') && (strncmp(argv[1], "trim", length) == 0) + && (length == 4)) { + char *trimChars; + register char *p, *checkPtr; + + left = right = 1; + + trim: + if (argc == 4) { + trimChars = argv[3]; + } else if (argc == 3) { + trimChars = " \t\n\r"; + } else { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " ", argv[1], " string ?chars?\"", (char *) NULL); + return TCL_ERROR; + } + p = argv[2]; + if (left) { + for (c = *p; c != 0; p++, c = *p) { + for (checkPtr = trimChars; *checkPtr != c; checkPtr++) { + if (*checkPtr == 0) { + goto doneLeft; + } + } + } + } + doneLeft: + Tcl_SetResult(interp, p, TCL_VOLATILE); + if (right) { + char *donePtr; + + p = interp->result + strlen(interp->result) - 1; + donePtr = &interp->result[-1]; + for (c = *p; p != donePtr; p--, c = *p) { + for (checkPtr = trimChars; *checkPtr != c; checkPtr++) { + if (*checkPtr == 0) { + goto doneRight; + } + } + } + doneRight: + p[1] = 0; + } + return TCL_OK; + } else if ((c == 't') && (strncmp(argv[1], "trimleft", length) == 0) + && (length > 4)) { + left = 1; + argv[1] = "trimleft"; + goto trim; + } else if ((c == 't') && (strncmp(argv[1], "trimright", length) == 0) + && (length > 4)) { + right = 1; + argv[1] = "trimright"; + goto trim; + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": should be compare, first, index, last, length, match, ", + "range, tolower, toupper, trim, trimleft, or trimright", + (char *) NULL); + return TCL_ERROR; + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SwitchCmd -- + * + * This procedure is invoked to process the "switch" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_SwitchCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ +#define EXACT 0 +#define GLOB 1 +#define REGEXP 2 + int i, code, mode, matched; + int body; + char *string; + int switchArgc, splitArgs; + char **switchArgv; + + switchArgc = argc-1; + switchArgv = argv+1; + mode = EXACT; + while ((switchArgc > 0) && (*switchArgv[0] == '-')) { + if (strcmp(*switchArgv, "-exact") == 0) { + mode = EXACT; + } else if (strcmp(*switchArgv, "-glob") == 0) { + mode = GLOB; + } else if (strcmp(*switchArgv, "-regexp") == 0) { + mode = REGEXP; + } else if (strcmp(*switchArgv, "--") == 0) { + switchArgc--; + switchArgv++; + break; + } else { + Tcl_AppendResult(interp, "bad option \"", switchArgv[0], + "\": should be -exact, -glob, -regexp, or --", + (char *) NULL); + return TCL_ERROR; + } + switchArgc--; + switchArgv++; + } + if (switchArgc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " ?switches? string pattern body ... ?default body?\"", + (char *) NULL); + return TCL_ERROR; + } + string = *switchArgv; + switchArgc--; + switchArgv++; + + /* + * If all of the pattern/command pairs are lumped into a single + * argument, split them out again. + */ + + splitArgs = 0; + if (switchArgc == 1) { + code = Tcl_SplitList(interp, switchArgv[0], &switchArgc, &switchArgv); + if (code != TCL_OK) { + return code; + } + splitArgs = 1; + } + + for (i = 0; i < switchArgc; i += 2) { + if (i == (switchArgc-1)) { + interp->result = "extra switch pattern with no body"; + code = TCL_ERROR; + goto cleanup; + } + + /* + * See if the pattern matches the string. + */ + + matched = 0; + if ((*switchArgv[i] == 'd') && (i == switchArgc-2) + && (strcmp(switchArgv[i], "default") == 0)) { + matched = 1; + } else { + switch (mode) { + case EXACT: + matched = (strcmp(string, switchArgv[i]) == 0); + break; + case GLOB: + matched = Tcl_StringMatch(string, switchArgv[i]); + break; + case REGEXP: + matched = Tcl_RegExpMatch(interp, string, switchArgv[i]); + if (matched < 0) { + code = TCL_ERROR; + goto cleanup; + } + break; + } + } + if (!matched) { + continue; + } + + /* + * We've got a match. Find a body to execute, skipping bodies + * that are "-". + */ + + for (body = i+1; ; body += 2) { + if (body >= switchArgc) { + Tcl_AppendResult(interp, "no body specified for pattern \"", + switchArgv[i], "\"", (char *) NULL); + code = TCL_ERROR; + goto cleanup; + } + if ((switchArgv[body][0] != '-') || (switchArgv[body][1] != 0)) { + break; + } + } + code = Tcl_Eval(interp, switchArgv[body]); + if (code == TCL_ERROR) { + char msg[100]; + sprintf(msg, "\n (\"%.50s\" arm line %d)", switchArgv[i], + interp->errorLine); + Tcl_AddErrorInfo(interp, msg); + } + goto cleanup; + } + + /* + * Nothing matched: return nothing. + */ + + code = TCL_OK; + + cleanup: + if (splitArgs) { + ckfree((char *) switchArgv); + } + return code; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_TraceCmd -- + * + * This procedure is invoked to process the "trace" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_TraceCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + char c; + int length; + + if (argc < 2) { + Tcl_AppendResult(interp, "too few args: should be \"", + argv[0], " option [arg arg ...]\"", (char *) NULL); + return TCL_ERROR; + } + c = argv[1][1]; + length = strlen(argv[1]); + if ((c == 'a') && (strncmp(argv[1], "variable", length) == 0) + && (length >= 2)) { + char *p; + int flags, length; + TraceVarInfo *tvarPtr; + + if (argc != 5) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " variable name ops command\"", (char *) NULL); + return TCL_ERROR; + } + + flags = 0; + for (p = argv[3] ; *p != 0; p++) { + if (*p == 'r') { + flags |= TCL_TRACE_READS; + } else if (*p == 'w') { + flags |= TCL_TRACE_WRITES; + } else if (*p == 'u') { + flags |= TCL_TRACE_UNSETS; + } else { + goto badOps; + } + } + if (flags == 0) { + goto badOps; + } + + length = strlen(argv[4]); + tvarPtr = (TraceVarInfo *) ckalloc((unsigned) + (sizeof(TraceVarInfo) - sizeof(tvarPtr->command) + length + 1)); + tvarPtr->flags = flags; + tvarPtr->errMsg = NULL; + tvarPtr->length = length; + flags |= TCL_TRACE_UNSETS; + strcpy(tvarPtr->command, argv[4]); + if (Tcl_TraceVar(interp, argv[2], flags, TraceVarProc, + (ClientData) tvarPtr) != TCL_OK) { + ckfree((char *) tvarPtr); + return TCL_ERROR; + } + } else if ((c == 'd') && (strncmp(argv[1], "vdelete", length) + && (length >= 2)) == 0) { + char *p; + int flags, length; + TraceVarInfo *tvarPtr; + ClientData clientData; + + if (argc != 5) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " vdelete name ops command\"", (char *) NULL); + return TCL_ERROR; + } + + flags = 0; + for (p = argv[3] ; *p != 0; p++) { + if (*p == 'r') { + flags |= TCL_TRACE_READS; + } else if (*p == 'w') { + flags |= TCL_TRACE_WRITES; + } else if (*p == 'u') { + flags |= TCL_TRACE_UNSETS; + } else { + goto badOps; + } + } + if (flags == 0) { + goto badOps; + } + + /* + * Search through all of our traces on this variable to + * see if there's one with the given command. If so, then + * delete the first one that matches. + */ + + length = strlen(argv[4]); + clientData = 0; + while ((clientData = Tcl_VarTraceInfo(interp, argv[2], 0, + TraceVarProc, clientData)) != 0) { + tvarPtr = (TraceVarInfo *) clientData; + if ((tvarPtr->length == length) && (tvarPtr->flags == flags) + && (strncmp(argv[4], tvarPtr->command, length) == 0)) { + Tcl_UntraceVar(interp, argv[2], flags | TCL_TRACE_UNSETS, + TraceVarProc, clientData); + if (tvarPtr->errMsg != NULL) { + ckfree(tvarPtr->errMsg); + } + ckfree((char *) tvarPtr); + break; + } + } + } else if ((c == 'i') && (strncmp(argv[1], "vinfo", length) == 0) + && (length >= 2)) { + ClientData clientData; + char ops[4], *p; + char *prefix = "{"; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " vinfo name\"", (char *) NULL); + return TCL_ERROR; + } + clientData = 0; + while ((clientData = Tcl_VarTraceInfo(interp, argv[2], 0, + TraceVarProc, clientData)) != 0) { + TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData; + p = ops; + if (tvarPtr->flags & TCL_TRACE_READS) { + *p = 'r'; + p++; + } + if (tvarPtr->flags & TCL_TRACE_WRITES) { + *p = 'w'; + p++; + } + if (tvarPtr->flags & TCL_TRACE_UNSETS) { + *p = 'u'; + p++; + } + *p = '\0'; + Tcl_AppendResult(interp, prefix, (char *) NULL); + Tcl_AppendElement(interp, ops); + Tcl_AppendElement(interp, tvarPtr->command); + Tcl_AppendResult(interp, "}", (char *) NULL); + prefix = " {"; + } + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": should be variable, vdelete, or vinfo", + (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; + + badOps: + Tcl_AppendResult(interp, "bad operations \"", argv[3], + "\": should be one or more of rwu", (char *) NULL); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * TraceVarProc -- + * + * This procedure is called to handle variable accesses that have + * been traced using the "trace" command. + * + * Results: + * Normally returns NULL. If the trace command returns an error, + * then this procedure returns an error string. + * + * Side effects: + * Depends on the command associated with the trace. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static char * +TraceVarProc(clientData, interp, name1, name2, flags) + ClientData clientData; /* Information about the variable trace. */ + Tcl_Interp *interp; /* Interpreter containing variable. */ + char *name1; /* Name of variable or array. */ + char *name2; /* Name of element within array; NULL means + * scalar variable is being referenced. */ + int flags; /* OR-ed bits giving operation and other + * information. */ +{ + TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData; + char *result; + int code; + Interp dummy; + Tcl_DString cmd; + + result = NULL; + if (tvarPtr->errMsg != NULL) { + ckfree(tvarPtr->errMsg); + tvarPtr->errMsg = NULL; + } + if ((tvarPtr->flags & flags) && !(flags & TCL_INTERP_DESTROYED)) { + + /* + * Generate a command to execute by appending list elements + * for the two variable names and the operation. The five + * extra characters are for three space, the opcode character, + * and the terminating null. + */ + + if (name2 == NULL) { + name2 = ""; + } + Tcl_DStringInit(&cmd); + Tcl_DStringAppend(&cmd, tvarPtr->command, tvarPtr->length); + Tcl_DStringAppendElement(&cmd, name1); + Tcl_DStringAppendElement(&cmd, name2); + if (flags & TCL_TRACE_READS) { + Tcl_DStringAppend(&cmd, " r", 2); + } else if (flags & TCL_TRACE_WRITES) { + Tcl_DStringAppend(&cmd, " w", 2); + } else if (flags & TCL_TRACE_UNSETS) { + Tcl_DStringAppend(&cmd, " u", 2); + } + + /* + * Execute the command. Be careful to save and restore the + * result from the interpreter used for the command. + */ + + if (interp->freeProc == 0) { + dummy.freeProc = (Tcl_FreeProc *) 0; + dummy.result = ""; + Tcl_SetResult((Tcl_Interp *) &dummy, interp->result, TCL_VOLATILE); + } else { + dummy.freeProc = interp->freeProc; + dummy.result = interp->result; + interp->freeProc = (Tcl_FreeProc *) 0; + } + code = Tcl_Eval(interp, Tcl_DStringValue(&cmd)); + Tcl_DStringFree(&cmd); + if (code != TCL_OK) { + tvarPtr->errMsg = ckalloc((unsigned) (strlen(interp->result) + 1)); + strcpy(tvarPtr->errMsg, interp->result); + result = tvarPtr->errMsg; + Tcl_ResetResult(interp); /* Must clear error state. */ + } + Tcl_SetResult(interp, dummy.result, + (dummy.freeProc == 0) ? TCL_VOLATILE : dummy.freeProc); + } + if (flags & TCL_TRACE_DESTROYED) { + result = NULL; + if (tvarPtr->errMsg != NULL) { + ckfree(tvarPtr->errMsg); + } + ckfree((char *) tvarPtr); + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_WhileCmd -- + * + * This procedure is invoked to process the "while" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_WhileCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int result, value; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " test command\"", (char *) NULL); + return TCL_ERROR; + } + + while (1) { + result = Tcl_ExprBoolean(interp, argv[1], &value); + if (result != TCL_OK) { + return result; + } + if (!value) { + break; + } + result = Tcl_Eval(interp, argv[2]); + if ((result != TCL_OK) && (result != TCL_CONTINUE)) { + if (result == TCL_ERROR) { + char msg[60]; + sprintf(msg, "\n (\"while\" body line %d)", + interp->errorLine); + Tcl_AddErrorInfo(interp, msg); + } + break; + } + } + if (result == TCL_BREAK) { + result = TCL_OK; + } + if (result == TCL_OK) { + Tcl_ResetResult(interp); + } + return result; +} diff --git a/vendor/x11iraf/obm/Tcl/tclEnv.c b/vendor/x11iraf/obm/Tcl/tclEnv.c new file mode 100644 index 00000000..012542fe --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/tclEnv.c @@ -0,0 +1,531 @@ +/* + * tclEnv.c -- + * + * Tcl support for environment variables, including a setenv + * procedure. + * + * Copyright (c) 1991-1993 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. + */ + +#ifndef lint +static char rcsid[] = "$Header: /user6/ouster/tcl/RCS/tclEnv.c,v 1.17 93/10/13 17:16:56 ouster Exp $ SPRITE (Berkeley)"; +#endif /* not lint */ + +/* + * The putenv and setenv definitions below cause any system prototypes for + * those procedures to be ignored so that there won't be a clash when the + * versions in this file are compiled. + */ + +#define putenv ignore_putenv +#define setenv ignore_setenv +#include "tclInt.h" +#include "tclUnix.h" +#undef putenv +#undef setenv + +/* + * The structure below is used to keep track of all of the interpereters + * for which we're managing the "env" array. It's needed so that they + * can all be updated whenever an environment variable is changed + * anywhere. + */ + +typedef struct EnvInterp { + Tcl_Interp *interp; /* Interpreter for which we're managing + * the env array. */ + struct EnvInterp *nextPtr; /* Next in list of all such interpreters, + * or zero. */ +} EnvInterp; + +static EnvInterp *firstInterpPtr; + /* First in list of all managed interpreters, + * or NULL if none. */ + +static int environSize = 0; /* Non-zero means that the all of the + * environ-related information is malloc-ed + * and the environ array itself has this + * many total entries allocated to it (not + * all may be in use at once). Zero means + * that the environment array is in its + * original static state. */ + +/* + * Declarations for local procedures defined in this file: + */ + +static void EnvInit _ANSI_ARGS_((void)); +static char * EnvTraceProc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, char *name1, char *name2, + int flags)); +static int FindVariable _ANSI_ARGS_((CONST char *name, + int *lengthPtr)); +void TclSetEnv _ANSI_ARGS_((CONST char *name, + CONST char *value)); +void TclUnsetEnv _ANSI_ARGS_((CONST char *name)); + +/* + *---------------------------------------------------------------------- + * + * TclSetupEnv -- + * + * This procedure is invoked for an interpreter to make environment + * variables accessible from that interpreter via the "env" + * associative array. + * + * Results: + * None. + * + * Side effects: + * The interpreter is added to a list of interpreters managed + * by us, so that its view of envariables can be kept consistent + * with the view in other interpreters. If this is the first + * call to Tcl_SetupEnv, then additional initialization happens, + * such as copying the environment to dynamically-allocated space + * for ease of management. + * + *---------------------------------------------------------------------- + */ + +void +TclSetupEnv(interp) + Tcl_Interp *interp; /* Interpreter whose "env" array is to be + * managed. */ +{ + EnvInterp *eiPtr; + int i; + + /* + * First, initialize our environment-related information, if + * necessary. + */ + + if (environSize == 0) { + EnvInit(); + } + + /* + * Next, add the interpreter to the list of those that we manage. + */ + + eiPtr = (EnvInterp *) ckalloc(sizeof(EnvInterp)); + eiPtr->interp = interp; + eiPtr->nextPtr = firstInterpPtr; + firstInterpPtr = eiPtr; + + /* + * Store the environment variable values into the interpreter's + * "env" array, and arrange for us to be notified on future + * writes and unsets to that array. + */ + + (void) Tcl_UnsetVar2(interp, "env", (char *) NULL, TCL_GLOBAL_ONLY); + for (i = 0; ; i++) { + char *p, *p2; + + p = environ[i]; + if (p == NULL) { + break; + } + for (p2 = p; *p2 != '='; p2++) { + /* Empty loop body. */ + } + *p2 = 0; + (void) Tcl_SetVar2(interp, "env", p, p2+1, TCL_GLOBAL_ONLY); + *p2 = '='; + } + Tcl_TraceVar2(interp, "env", (char *) NULL, + TCL_GLOBAL_ONLY | TCL_TRACE_WRITES | TCL_TRACE_UNSETS, + EnvTraceProc, (ClientData) NULL); +} + +/* + *---------------------------------------------------------------------- + * + * FindVariable -- + * + * Locate the entry in environ for a given name. + * + * Results: + * The return value is the index in environ of an entry with the + * name "name", or -1 if there is no such entry. The integer at + * *lengthPtr is filled in with the length of name (if a matching + * entry is found) or the length of the environ array (if no matching + * entry is found). + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +FindVariable(name, lengthPtr) + CONST char *name; /* Name of desired environment variable. */ + int *lengthPtr; /* Used to return length of name (for + * successful searches) or number of non-NULL + * entries in environ (for unsuccessful + * searches). */ +{ + int i; + CONST char *p1, *p2; + + for (i = 0, p1 = environ[i]; p1 != NULL; i++, p1 = environ[i]) { + for (p2 = name; *p2 == *p1; p1++, p2++) { + /* NULL loop body. */ + } + if ((*p1 == '=') && (*p2 == '\0')) { + *lengthPtr = p2-name; + return i; + } + } + *lengthPtr = i; + return -1; +} + +/* + *---------------------------------------------------------------------- + * + * TclSetEnv -- + * + * Set an environment variable, replacing an existing value + * or creating a new variable if there doesn't exist a variable + * by the given name. This procedure is intended to be a + * stand-in for the UNIX "setenv" procedure so that applications + * using that procedure will interface properly to Tcl. To make + * it a stand-in, the Makefile must define "TclSetEnv" to "setenv". + * + * Results: + * None. + * + * Side effects: + * The environ array gets updated, as do all of the interpreters + * that we manage. + * + *---------------------------------------------------------------------- + */ + +void +TclSetEnv(name, value) + CONST char *name; /* Name of variable whose value is to be + * set. */ + CONST char *value; /* New value for variable. */ +{ + int index, length, nameLength; + char *p; + EnvInterp *eiPtr; + + if (environSize == 0) { + EnvInit(); + } + + /* + * Figure out where the entry is going to go. If the name doesn't + * already exist, enlarge the array if necessary to make room. If + * the name exists, free its old entry. + */ + + index = FindVariable(name, &length); + if (index == -1) { + if ((length+2) > environSize) { + char **newEnviron; + + newEnviron = (char **) ckalloc((unsigned) + ((length+5) * sizeof(char *))); + memcpy((VOID *) newEnviron, (VOID *) environ, + length*sizeof(char *)); + ckfree((char *) environ); + environ = newEnviron; + environSize = length+5; + } + index = length; + environ[index+1] = NULL; + nameLength = strlen(name); + } else { + /* + * Compare the new value to the existing value. If they're + * the same then quit immediately (e.g. don't rewrite the + * value or propagate it to other interpreters). Otherwise, + * when there are N interpreters there will be N! propagations + * of the same value among the interpreters. + */ + + if (strcmp(value, environ[index]+length+1) == 0) { + return; + } + ckfree(environ[index]); + nameLength = length; + } + + /* + * Create a new entry and enter it into the table. + */ + + p = (char *) ckalloc((unsigned) (nameLength + strlen(value) + 2)); + environ[index] = p; + strcpy(p, name); + p += nameLength; + *p = '='; + strcpy(p+1, value); + + /* + * Update all of the interpreters. + */ + + for (eiPtr= firstInterpPtr; eiPtr != NULL; eiPtr = eiPtr->nextPtr) { + (void) Tcl_SetVar2(eiPtr->interp, "env", (char *) name, + p+1, TCL_GLOBAL_ONLY); + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_PutEnv -- + * + * Set an environment variable. Similar to setenv except that + * the information is passed in a single string of the form + * NAME=value, rather than as separate name strings. This procedure + * is intended to be a stand-in for the UNIX "putenv" procedure + * so that applications using that procedure will interface + * properly to Tcl. To make it a stand-in, the Makefile will + * define "Tcl_PutEnv" to "putenv". + * + * Results: + * None. + * + * Side effects: + * The environ array gets updated, as do all of the interpreters + * that we manage. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_PutEnv(string) + CONST char *string; /* Info about environment variable in the + * form NAME=value. */ +{ + int nameLength; + char *name, *value; + + if (string == NULL) { + return 0; + } + + /* + * Separate the string into name and value parts, then call + * TclSetEnv to do all of the real work. + */ + + value = strchr(string, '='); + if (value == NULL) { + return 0; + } + nameLength = value - string; + if (nameLength == 0) { + return 0; + } + name = ckalloc((unsigned) nameLength+1); + memcpy(name, string, nameLength); + name[nameLength] = 0; + TclSetEnv(name, value+1); + ckfree(name); + return 0; +} + +/* + *---------------------------------------------------------------------- + * + * TclUnsetEnv -- + * + * Remove an environment variable, updating the "env" arrays + * in all interpreters managed by us. This function is intended + * to replace the UNIX "unsetenv" function (but to do this the + * Makefile must be modified to redefine "TclUnsetEnv" to + * "unsetenv". + * + * Results: + * None. + * + * Side effects: + * Interpreters are updated, as is environ. + * + *---------------------------------------------------------------------- + */ + +void +TclUnsetEnv(name) + CONST char *name; /* Name of variable to remove. */ +{ + int index, dummy; + char **envPtr; + EnvInterp *eiPtr; + + if (environSize == 0) { + EnvInit(); + } + + /* + * Update the environ array. + */ + + index = FindVariable(name, &dummy); + if (index == -1) { + return; + } + ckfree(environ[index]); + for (envPtr = environ+index+1; ; envPtr++) { + envPtr[-1] = *envPtr; + if (*envPtr == NULL) { + break; + } + } + + /* + * Update all of the interpreters. + */ + + for (eiPtr = firstInterpPtr; eiPtr != NULL; eiPtr = eiPtr->nextPtr) { + (void) Tcl_UnsetVar2(eiPtr->interp, "env", (char *) name, + TCL_GLOBAL_ONLY); + } +} + +/* + *---------------------------------------------------------------------- + * + * EnvTraceProc -- + * + * This procedure is invoked whenever an environment variable + * is modified or deleted. It propagates the change to the + * "environ" array and to any other interpreters for whom + * we're managing an "env" array. + * + * Results: + * Always returns NULL to indicate success. + * + * Side effects: + * Environment variable changes get propagated. If the whole + * "env" array is deleted, then we stop managing things for + * this interpreter (usually this happens because the whole + * interpreter is being deleted). + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static char * +EnvTraceProc(clientData, interp, name1, name2, flags) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Interpreter whose "env" variable is + * being modified. */ + char *name1; /* Better be "env". */ + char *name2; /* Name of variable being modified, or + * NULL if whole array is being deleted. */ + int flags; /* Indicates what's happening. */ +{ + /* + * First see if the whole "env" variable is being deleted. If + * so, just forget about this interpreter. + */ + + if (name2 == NULL) { + register EnvInterp *eiPtr, *prevPtr; + + if ((flags & (TCL_TRACE_UNSETS|TCL_TRACE_DESTROYED)) + != (TCL_TRACE_UNSETS|TCL_TRACE_DESTROYED)) { + panic("EnvTraceProc called with confusing arguments"); + } + eiPtr = firstInterpPtr; + if (eiPtr->interp == interp) { + firstInterpPtr = eiPtr->nextPtr; + } else { + for (prevPtr = eiPtr, eiPtr = eiPtr->nextPtr; ; + prevPtr = eiPtr, eiPtr = eiPtr->nextPtr) { + if (eiPtr == NULL) { + panic("EnvTraceProc couldn't find interpreter"); + } + if (eiPtr->interp == interp) { + prevPtr->nextPtr = eiPtr->nextPtr; + break; + } + } + } + ckfree((char *) eiPtr); + return NULL; + } + + /* + * If a value is being set, call TclSetEnv to do all of the work. + */ + + if (flags & TCL_TRACE_WRITES) { + TclSetEnv(name2, Tcl_GetVar2(interp, "env", name2, TCL_GLOBAL_ONLY)); + } + + if (flags & TCL_TRACE_UNSETS) { + TclUnsetEnv(name2); + } + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * EnvInit -- + * + * This procedure is called to initialize our management + * of the environ array. + * + * Results: + * None. + * + * Side effects: + * Environ gets copied to malloc-ed storage, so that in + * the future we don't have to worry about which entries + * are malloc-ed and which are static. + * + *---------------------------------------------------------------------- + */ + +static void +EnvInit() +{ + char **newEnviron; + int i, length; + + if (environSize != 0) { + return; + } + for (length = 0; environ[length] != NULL; length++) { + /* Empty loop body. */ + } + environSize = length+5; + newEnviron = (char **) ckalloc((unsigned) + (environSize * sizeof(char *))); + for (i = 0; i < length; i++) { + newEnviron[i] = (char *) ckalloc((unsigned) (strlen(environ[i]) + 1)); + strcpy(newEnviron[i], environ[i]); + } + newEnviron[length] = NULL; + environ = newEnviron; +} diff --git a/vendor/x11iraf/obm/Tcl/tclExpr.c b/vendor/x11iraf/obm/Tcl/tclExpr.c new file mode 100644 index 00000000..45780842 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/tclExpr.c @@ -0,0 +1,2011 @@ +/* + * tclExpr.c -- + * + * This file contains the code to evaluate expressions for + * Tcl. + * + * This implementation of floating-point support was modelled + * after an initial implementation by Bill Carpenter. + * + * Copyright (c) 1987-1993 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. + */ + +#ifndef lint +static char rcsid[] = "$Header: /user6/ouster/tcl/RCS/tclExpr.c,v 1.68 93/10/31 16:19:44 ouster Exp $ SPRITE (Berkeley)"; +#endif + +#include "tclInt.h" +#ifdef NO_FLOAT_H +# include "compat/float.h" +#else +# include <float.h> +#endif +#ifndef TCL_NO_MATH +#include <math.h> +#endif + +/* + * The stuff below is a bit of a hack so that this file can be used + * in environments that include no UNIX, i.e. no errno. Just define + * errno here. + */ + +#ifndef TCL_GENERIC_ONLY +#include "tclUnix.h" +extern int errno; +#else +#define NO_ERRNO_H +#endif + +#ifdef NO_ERRNO_H +int errno; +#define EDOM 33 +#define ERANGE 34 +#endif + +/* Slackware/RedHat4.2 compatibility hack. */ +#if defined(linux) && defined(isalnum) +#undef isalnum +#define isalnum(c) (isalpha(c)||isdigit(c)) +#endif + + +/* + * The data structure below is used to describe an expression value, + * which can be either an integer (the usual case), a double-precision + * floating-point value, or a string. A given number has only one + * value at a time. + */ + +#define STATIC_STRING_SPACE 150 + +typedef struct { + long intValue; /* Integer value, if any. */ + double doubleValue; /* Floating-point value, if any. */ + ParseValue pv; /* Used to hold a string value, if any. */ + char staticSpace[STATIC_STRING_SPACE]; + /* Storage for small strings; large ones + * are malloc-ed. */ + int type; /* Type of value: TYPE_INT, TYPE_DOUBLE, + * or TYPE_STRING. */ +} Value; + +/* + * Valid values for type: + */ + +#define TYPE_INT 0 +#define TYPE_DOUBLE 1 +#define TYPE_STRING 2 + +/* + * The data structure below describes the state of parsing an expression. + * It's passed among the routines in this module. + */ + +typedef struct { + char *originalExpr; /* The entire expression, as originally + * passed to Tcl_ExprString et al. */ + char *expr; /* Position to the next character to be + * scanned from the expression string. */ + int token; /* Type of the last token to be parsed from + * expr. See below for definitions. + * Corresponds to the characters just + * before expr. */ +} ExprInfo; + +/* + * The token types are defined below. In addition, there is a table + * associating a precedence with each operator. The order of types + * is important. Consult the code before changing it. + */ + +#define VALUE 0 +#define OPEN_PAREN 1 +#define CLOSE_PAREN 2 +#define COMMA 3 +#define END 4 +#define UNKNOWN 5 + +/* + * Binary operators: + */ + +#define MULT 8 +#define DIVIDE 9 +#define MOD 10 +#define PLUS 11 +#define MINUS 12 +#define LEFT_SHIFT 13 +#define RIGHT_SHIFT 14 +#define LESS 15 +#define GREATER 16 +#define LEQ 17 +#define GEQ 18 +#define EQUAL 19 +#define NEQ 20 +#define BIT_AND 21 +#define BIT_XOR 22 +#define BIT_OR 23 +#define AND 24 +#define OR 25 +#define QUESTY 26 +#define COLON 27 + +/* + * Unary operators: + */ + +#define UNARY_MINUS 28 +#define NOT 29 +#define BIT_NOT 30 + +/* + * Precedence table. The values for non-operator token types are ignored. + */ + +int precTable[] = { + 0, 0, 0, 0, 0, 0, 0, 0, + 11, 11, 11, /* MULT, DIVIDE, MOD */ + 10, 10, /* PLUS, MINUS */ + 9, 9, /* LEFT_SHIFT, RIGHT_SHIFT */ + 8, 8, 8, 8, /* LESS, GREATER, LEQ, GEQ */ + 7, 7, /* EQUAL, NEQ */ + 6, /* BIT_AND */ + 5, /* BIT_XOR */ + 4, /* BIT_OR */ + 3, /* AND */ + 2, /* OR */ + 1, 1, /* QUESTY, COLON */ + 12, 12, 12 /* UNARY_MINUS, NOT, BIT_NOT */ +}; + +/* + * Mapping from operator numbers to strings; used for error messages. + */ + +char *operatorStrings[] = { + "VALUE", "(", ")", "END", "UNKNOWN", "5", "6", "7", + "*", "/", "%", "+", "-", "<<", ">>", "<", ">", "<=", + ">=", "==", "!=", "&", "^", "|", "&&", "||", "?", ":", + "-", "!", "~" +}; + +/* + * The following slight modification to DBL_MAX is needed because of + * a compiler bug on Sprite (4/15/93). + */ + +#ifdef sprite +#undef DBL_MAX +#define DBL_MAX 1.797693134862316e+307 +#endif + +/* + * Macros for testing floating-point values for certain special + * cases. Test for not-a-number by comparing a value against + * itself; test for infinity by comparing against the largest + * floating-point value. + */ + +#define IS_NAN(v) ((v) != (v)) +#ifdef DBL_MAX +# define IS_INF(v) (((v) > DBL_MAX) || ((v) < -DBL_MAX)) +#else +# define IS_INF(v) 0 +#endif + +/* + * The following global variable is use to signal matherr that Tcl + * is responsible for the arithmetic, so errors can be handled in a + * fashion appropriate for Tcl. Zero means no Tcl math is in + * progress; non-zero means Tcl is doing math. + */ + +int tcl_MathInProgress = 0; + +/* + * The variable below serves no useful purpose except to generate + * a reference to matherr, so that the Tcl version of matherr is + * linked in rather than the system version. Without this reference + * the need for matherr won't be discovered during linking until after + * libtcl.a has been processed, so Tcl's version won't be used. + */ + +#ifdef NEED_MATHERR +extern int matherr(); +int (*tclMatherrPtr)() = matherr; +#endif + +/* + * Declarations for local procedures to this file: + */ + +static int ExprAbsFunc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, Tcl_Value *args, + Tcl_Value *resultPtr)); +static int ExprBinaryFunc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, Tcl_Value *args, + Tcl_Value *resultPtr)); +static int ExprDoubleFunc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, Tcl_Value *args, + Tcl_Value *resultPtr)); +static void ExprFloatError _ANSI_ARGS_((Tcl_Interp *interp, + double value)); +static int ExprGetValue _ANSI_ARGS_((Tcl_Interp *interp, + ExprInfo *infoPtr, int prec, Value *valuePtr)); +static int ExprIntFunc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, Tcl_Value *args, + Tcl_Value *resultPtr)); +static int ExprLex _ANSI_ARGS_((Tcl_Interp *interp, + ExprInfo *infoPtr, Value *valuePtr)); +static void ExprMakeString _ANSI_ARGS_((Tcl_Interp *interp, + Value *valuePtr)); +static int ExprMathFunc _ANSI_ARGS_((Tcl_Interp *interp, + ExprInfo *infoPtr, Value *valuePtr)); +static int ExprParseString _ANSI_ARGS_((Tcl_Interp *interp, + char *string, Value *valuePtr)); +static int ExprRoundFunc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, Tcl_Value *args, + Tcl_Value *resultPtr)); +static int ExprTopLevel _ANSI_ARGS_((Tcl_Interp *interp, + char *string, Value *valuePtr)); +static int ExprUnaryFunc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, Tcl_Value *args, + Tcl_Value *resultPtr)); + +/* + * Built-in math functions: + */ + +typedef struct { + char *name; /* Name of function. */ + int numArgs; /* Number of arguments for function. */ + Tcl_ValueType argTypes[MAX_MATH_ARGS]; + /* Acceptable types for each argument. */ + Tcl_MathProc *proc; /* Procedure that implements this function. */ + ClientData clientData; /* Additional argument to pass to the function + * when invoking it. */ +} BuiltinFunc; + +static BuiltinFunc funcTable[] = { +#ifndef TCL_NO_MATH + {"acos", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) acos}, + {"asin", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) asin}, + {"atan", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) atan}, + {"atan2", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) atan2}, + {"ceil", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) ceil}, + {"cos", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) cos}, + {"cosh", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) cosh}, + {"exp", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) exp}, + {"floor", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) floor}, + {"fmod", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) fmod}, + {"hypot", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) hypot}, + {"log", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) log}, + {"log10", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) log10}, + {"pow", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) pow}, + {"sin", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) sin}, + {"sinh", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) sinh}, + {"sqrt", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) sqrt}, + {"tan", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) tan}, + {"tanh", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) tanh}, +#endif + {"abs", 1, {TCL_EITHER}, ExprAbsFunc, 0}, + {"double", 1, {TCL_EITHER}, ExprDoubleFunc, 0}, + {"int", 1, {TCL_EITHER}, ExprIntFunc, 0}, + {"round", 1, {TCL_EITHER}, ExprRoundFunc, 0}, + {0,0,{0},0,0}, +}; + +/* + *-------------------------------------------------------------- + * + * ExprParseString -- + * + * Given a string (such as one coming from command or variable + * substitution), make a Value based on the string. The value + * will be a floating-point or integer, if possible, or else it + * will just be a copy of the string. + * + * Results: + * TCL_OK is returned under normal circumstances, and TCL_ERROR + * is returned if a floating-point overflow or underflow occurred + * while reading in a number. The value at *valuePtr is modified + * to hold a number, if possible. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +static int +ExprParseString(interp, string, valuePtr) + Tcl_Interp *interp; /* Where to store error message. */ + char *string; /* String to turn into value. */ + Value *valuePtr; /* Where to store value information. + * Caller must have initialized pv field. */ +{ + char *term, *p, *start; + + if (*string != 0) { + valuePtr->type = TYPE_INT; + errno = 0; + + /* + * 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. + */ + + for (p = string; isspace(UCHAR(*p)); p++) { + /* Empty loop body. */ + } + if (*p == '-') { + start = p+1; + valuePtr->intValue = -strtoul(start, &term, 0); + } else if (*p == '+') { + start = p+1; + valuePtr->intValue = strtoul(start, &term, 0); + } else { + start = p; + valuePtr->intValue = strtoul(start, &term, 0); + } + if (errno == ERANGE) { + /* + * This procedure is sometimes called with string in + * interp->result, so we have to clear the result before + * logging an error message. + */ + + Tcl_ResetResult(interp); + interp->result = "integer value too large to represent"; + Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", interp->result, + (char *) NULL); + return TCL_ERROR; + } + if ((term != start) && (*term == '\0')) { + return TCL_OK; + } + errno = 0; + valuePtr->doubleValue = strtod(p, &term); + if ((term != p) && (*term == '\0')) { + if (errno != 0) { + Tcl_ResetResult(interp); + ExprFloatError(interp, valuePtr->doubleValue); + return TCL_ERROR; + } + valuePtr->type = TYPE_DOUBLE; + return TCL_OK; + } + } + + /* + * Not a valid number. Save a string value (but don't do anything + * if it's already the value). + */ + + valuePtr->type = TYPE_STRING; + if (string != valuePtr->pv.buffer) { + int length, shortfall; + + length = strlen(string); + valuePtr->pv.next = valuePtr->pv.buffer; + shortfall = length - (valuePtr->pv.end - valuePtr->pv.buffer); + if (shortfall > 0) { + (*valuePtr->pv.expandProc)(&valuePtr->pv, shortfall); + } + strcpy(valuePtr->pv.buffer, string); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * ExprLex -- + * + * Lexical analyzer for expression parser: parses a single value, + * operator, or other syntactic element from an expression string. + * + * Results: + * TCL_OK is returned unless an error occurred while doing lexical + * analysis or executing an embedded command. In that case a + * standard Tcl error is returned, using interp->result to hold + * an error message. In the event of a successful return, the token + * and field in infoPtr is updated to refer to the next symbol in + * the expression string, and the expr field is advanced past that + * token; if the token is a value, then the value is stored at + * valuePtr. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +ExprLex(interp, infoPtr, valuePtr) + Tcl_Interp *interp; /* Interpreter to use for error + * reporting. */ + register ExprInfo *infoPtr; /* Describes the state of the parse. */ + register Value *valuePtr; /* Where to store value, if that is + * what's parsed from string. Caller + * must have initialized pv field + * correctly. */ +{ + register char *p; + char *var, *term; + int result; + + p = infoPtr->expr; + while (isspace(UCHAR(*p))) { + p++; + } + if (*p == 0) { + infoPtr->token = END; + infoPtr->expr = p; + return TCL_OK; + } + + /* + * First try to parse the token as an integer or floating-point number. + * A couple of tricky points: + * + * 1. Can't just check for leading digits to see if there's a number + * there, because it could be a special value like "NaN". + * 2. Don't want to check for a number if the first character is "+" + * or "-". If we do, we might treat a binary operator as unary + * by mistake, which will eventually cause a syntax error. + * 3. First see if there's an integer, then if there's stuff after + * the integer that looks like it could be a floating-point number + * (or if there wasn't even a sensible integer), then try to parse + * as a floating-point number. The check for the characters '8' + * or '9' is to handle floating-point numbers like 028.6: the + * leading zero causes strtoul to interpret the number as octal + * and stop when it gets to the 8. + */ + + if ((*p != '+') && (*p != '-')) { + errno = 0; + valuePtr->intValue = strtoul(p, &term, 0); + if ((term == p) || (*term == '.') || (*term == 'e') || + (*term == 'E') || (*term == '8') || (*term == '9')) { + char *term2; + + /* + * The code here is a bit tricky: we want to use a floating-point + * number if there is one, but if there isn't then fall through to + * use the integer that was already parsed, if there was one. + */ + + errno = 0; + valuePtr->doubleValue = strtod(p, &term2); + if (term2 != p) { + if (errno != 0) { + ExprFloatError(interp, valuePtr->doubleValue); + return TCL_ERROR; + } + infoPtr->token = VALUE; + infoPtr->expr = term2; + valuePtr->type = TYPE_DOUBLE; + return TCL_OK; + } + if (term != p) { + interp->result = "poorly-formed floating-point value"; + return TCL_ERROR; + } + } + if (term != p) { + /* + * No floating-point number, but there is an integer. + */ + + if (errno == ERANGE) { + interp->result = "integer value too large to represent"; + Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", interp->result, + (char *) NULL); + return TCL_ERROR; + } + infoPtr->token = VALUE; + infoPtr->expr = term; + valuePtr->type = TYPE_INT; + return TCL_OK; + } + } + + infoPtr->expr = p+1; + switch (*p) { + case '$': + + /* + * Variable. Fetch its value, then see if it makes sense + * as an integer or floating-point number. + */ + + infoPtr->token = VALUE; + var = Tcl_ParseVar(interp, p, &infoPtr->expr); + if (var == NULL) { + return TCL_ERROR; + } + Tcl_ResetResult(interp); + if (((Interp *) interp)->noEval) { + valuePtr->type = TYPE_INT; + valuePtr->intValue = 0; + return TCL_OK; + } + return ExprParseString(interp, var, valuePtr); + + case '[': + infoPtr->token = VALUE; + ((Interp *) interp)->evalFlags = TCL_BRACKET_TERM; + result = Tcl_Eval(interp, p+1); + infoPtr->expr = ((Interp *) interp)->termPtr; + if (result != TCL_OK) { + return result; + } + infoPtr->expr++; + if (((Interp *) interp)->noEval) { + valuePtr->type = TYPE_INT; + valuePtr->intValue = 0; + Tcl_ResetResult(interp); + return TCL_OK; + } + result = ExprParseString(interp, interp->result, valuePtr); + if (result != TCL_OK) { + return result; + } + Tcl_ResetResult(interp); + return TCL_OK; + + case '"': + infoPtr->token = VALUE; + result = TclParseQuotes(interp, infoPtr->expr, '"', 0, + &infoPtr->expr, &valuePtr->pv); + if (result != TCL_OK) { + return result; + } + Tcl_ResetResult(interp); + return ExprParseString(interp, valuePtr->pv.buffer, valuePtr); + + case '{': + infoPtr->token = VALUE; + result = TclParseBraces(interp, infoPtr->expr, &infoPtr->expr, + &valuePtr->pv); + if (result != TCL_OK) { + return result; + } + Tcl_ResetResult(interp); + return ExprParseString(interp, valuePtr->pv.buffer, valuePtr); + + case '(': + infoPtr->token = OPEN_PAREN; + return TCL_OK; + + case ')': + infoPtr->token = CLOSE_PAREN; + return TCL_OK; + + case ',': + infoPtr->token = COMMA; + return TCL_OK; + + case '*': + infoPtr->token = MULT; + return TCL_OK; + + case '/': + infoPtr->token = DIVIDE; + return TCL_OK; + + case '%': + infoPtr->token = MOD; + return TCL_OK; + + case '+': + infoPtr->token = PLUS; + return TCL_OK; + + case '-': + infoPtr->token = MINUS; + return TCL_OK; + + case '?': + infoPtr->token = QUESTY; + return TCL_OK; + + case ':': + infoPtr->token = COLON; + return TCL_OK; + + case '<': + switch (p[1]) { + case '<': + infoPtr->expr = p+2; + infoPtr->token = LEFT_SHIFT; + break; + case '=': + infoPtr->expr = p+2; + infoPtr->token = LEQ; + break; + default: + infoPtr->token = LESS; + break; + } + return TCL_OK; + + case '>': + switch (p[1]) { + case '>': + infoPtr->expr = p+2; + infoPtr->token = RIGHT_SHIFT; + break; + case '=': + infoPtr->expr = p+2; + infoPtr->token = GEQ; + break; + default: + infoPtr->token = GREATER; + break; + } + return TCL_OK; + + case '=': + if (p[1] == '=') { + infoPtr->expr = p+2; + infoPtr->token = EQUAL; + } else { + infoPtr->token = UNKNOWN; + } + return TCL_OK; + + case '!': + if (p[1] == '=') { + infoPtr->expr = p+2; + infoPtr->token = NEQ; + } else { + infoPtr->token = NOT; + } + return TCL_OK; + + case '&': + if (p[1] == '&') { + infoPtr->expr = p+2; + infoPtr->token = AND; + } else { + infoPtr->token = BIT_AND; + } + return TCL_OK; + + case '^': + infoPtr->token = BIT_XOR; + return TCL_OK; + + case '|': + if (p[1] == '|') { + infoPtr->expr = p+2; + infoPtr->token = OR; + } else { + infoPtr->token = BIT_OR; + } + return TCL_OK; + + case '~': + infoPtr->token = BIT_NOT; + return TCL_OK; + + default: + if (isalpha(UCHAR(*p))) { + infoPtr->expr = p; + return ExprMathFunc(interp, infoPtr, valuePtr); + } + infoPtr->expr = p+1; + infoPtr->token = UNKNOWN; + return TCL_OK; + } +} + +/* + *---------------------------------------------------------------------- + * + * ExprGetValue -- + * + * Parse a "value" from the remainder of the expression in infoPtr. + * + * Results: + * Normally TCL_OK is returned. The value of the expression is + * returned in *valuePtr. If an error occurred, then interp->result + * contains an error message and TCL_ERROR is returned. + * InfoPtr->token will be left pointing to the token AFTER the + * expression, and infoPtr->expr will point to the character just + * after the terminating token. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +ExprGetValue(interp, infoPtr, prec, valuePtr) + Tcl_Interp *interp; /* Interpreter to use for error + * reporting. */ + register ExprInfo *infoPtr; /* Describes the state of the parse + * just before the value (i.e. ExprLex + * will be called to get first token + * of value). */ + int prec; /* Treat any un-parenthesized operator + * with precedence <= this as the end + * of the expression. */ + Value *valuePtr; /* Where to store the value of the + * expression. Caller must have + * initialized pv field. */ +{ + Interp *iPtr = (Interp *) interp; + Value value2; /* Second operand for current + * operator. */ + int operator; /* Current operator (either unary + * or binary). */ + int badType; /* Type of offending argument; used + * for error messages. */ + int gotOp; /* Non-zero means already lexed the + * operator (while picking up value + * for unary operator). Don't lex + * again. */ + int result; + + /* + * There are two phases to this procedure. First, pick off an initial + * value. Then, parse (binary operator, value) pairs until done. + */ + + gotOp = 0; + value2.pv.buffer = value2.pv.next = value2.staticSpace; + value2.pv.end = value2.pv.buffer + STATIC_STRING_SPACE - 1; + value2.pv.expandProc = TclExpandParseValue; + value2.pv.clientData = (ClientData) NULL; + result = ExprLex(interp, infoPtr, valuePtr); + if (result != TCL_OK) { + goto done; + } + if (infoPtr->token == OPEN_PAREN) { + + /* + * Parenthesized sub-expression. + */ + + result = ExprGetValue(interp, infoPtr, -1, valuePtr); + if (result != TCL_OK) { + goto done; + } + if (infoPtr->token != CLOSE_PAREN) { + Tcl_AppendResult(interp, "unmatched parentheses in expression \"", + infoPtr->originalExpr, "\"", (char *) NULL); + result = TCL_ERROR; + goto done; + } + } else { + if (infoPtr->token == MINUS) { + infoPtr->token = UNARY_MINUS; + } + if (infoPtr->token >= UNARY_MINUS) { + + /* + * Process unary operators. + */ + + operator = infoPtr->token; + result = ExprGetValue(interp, infoPtr, precTable[infoPtr->token], + valuePtr); + if (result != TCL_OK) { + goto done; + } + switch (operator) { + case UNARY_MINUS: + if (valuePtr->type == TYPE_INT) { + valuePtr->intValue = -valuePtr->intValue; + } else if (valuePtr->type == TYPE_DOUBLE){ + valuePtr->doubleValue = -valuePtr->doubleValue; + } else { + badType = valuePtr->type; + goto illegalType; + } + break; + case NOT: + if (valuePtr->type == TYPE_INT) { + valuePtr->intValue = !valuePtr->intValue; + } else if (valuePtr->type == TYPE_DOUBLE) { + /* + * Theoretically, should be able to use + * "!valuePtr->intValue", but apparently some + * compilers can't handle it. + */ + if (valuePtr->doubleValue == 0.0) { + valuePtr->intValue = 1; + } else { + valuePtr->intValue = 0; + } + valuePtr->type = TYPE_INT; + } else { + badType = valuePtr->type; + goto illegalType; + } + break; + case BIT_NOT: + if (valuePtr->type == TYPE_INT) { + valuePtr->intValue = ~valuePtr->intValue; + } else { + badType = valuePtr->type; + goto illegalType; + } + break; + } + gotOp = 1; + } else if (infoPtr->token != VALUE) { + goto syntaxError; + } + } + + /* + * Got the first operand. Now fetch (operator, operand) pairs. + */ + + if (!gotOp) { + result = ExprLex(interp, infoPtr, &value2); + if (result != TCL_OK) { + goto done; + } + } + while (1) { + operator = infoPtr->token; + value2.pv.next = value2.pv.buffer; + if ((operator < MULT) || (operator >= UNARY_MINUS)) { + if ((operator == END) || (operator == CLOSE_PAREN) + || (operator == COMMA)) { + result = TCL_OK; + goto done; + } else { + goto syntaxError; + } + } + if (precTable[operator] <= prec) { + result = TCL_OK; + goto done; + } + + /* + * If we're doing an AND or OR and the first operand already + * determines the result, don't execute anything in the + * second operand: just parse. Same style for ?: pairs. + */ + + if ((operator == AND) || (operator == OR) || (operator == QUESTY)) { + if (valuePtr->type == TYPE_DOUBLE) { + valuePtr->intValue = valuePtr->doubleValue != 0; + valuePtr->type = TYPE_INT; + } else if (valuePtr->type == TYPE_STRING) { + badType = TYPE_STRING; + goto illegalType; + } + if (((operator == AND) && !valuePtr->intValue) + || ((operator == OR) && valuePtr->intValue)) { + iPtr->noEval++; + result = ExprGetValue(interp, infoPtr, precTable[operator], + &value2); + iPtr->noEval--; + } else if (operator == QUESTY) { + if (valuePtr->intValue != 0) { + valuePtr->pv.next = valuePtr->pv.buffer; + result = ExprGetValue(interp, infoPtr, precTable[operator], + valuePtr); + if (result != TCL_OK) { + goto done; + } + if (infoPtr->token != COLON) { + goto syntaxError; + } + value2.pv.next = value2.pv.buffer; + iPtr->noEval++; + result = ExprGetValue(interp, infoPtr, precTable[operator], + &value2); + iPtr->noEval--; + } else { + iPtr->noEval++; + result = ExprGetValue(interp, infoPtr, precTable[operator], + &value2); + iPtr->noEval--; + if (result != TCL_OK) { + goto done; + } + if (infoPtr->token != COLON) { + goto syntaxError; + } + valuePtr->pv.next = valuePtr->pv.buffer; + result = ExprGetValue(interp, infoPtr, precTable[operator], + valuePtr); + } + } else { + result = ExprGetValue(interp, infoPtr, precTable[operator], + &value2); + } + } else { + result = ExprGetValue(interp, infoPtr, precTable[operator], + &value2); + } + if (result != TCL_OK) { + goto done; + } + if ((infoPtr->token < MULT) && (infoPtr->token != VALUE) + && (infoPtr->token != END) && (infoPtr->token != COMMA) + && (infoPtr->token != CLOSE_PAREN)) { + goto syntaxError; + } + + /* + * At this point we've got two values and an operator. Check + * to make sure that the particular data types are appropriate + * for the particular operator, and perform type conversion + * if necessary. + */ + + switch (operator) { + + /* + * For the operators below, no strings are allowed and + * ints get converted to floats if necessary. + */ + + case MULT: case DIVIDE: case PLUS: case MINUS: + if ((valuePtr->type == TYPE_STRING) + || (value2.type == TYPE_STRING)) { + badType = TYPE_STRING; + goto illegalType; + } + if (valuePtr->type == TYPE_DOUBLE) { + if (value2.type == TYPE_INT) { + value2.doubleValue = value2.intValue; + value2.type = TYPE_DOUBLE; + } + } else if (value2.type == TYPE_DOUBLE) { + if (valuePtr->type == TYPE_INT) { + valuePtr->doubleValue = valuePtr->intValue; + valuePtr->type = TYPE_DOUBLE; + } + } + break; + + /* + * For the operators below, only integers are allowed. + */ + + case MOD: case LEFT_SHIFT: case RIGHT_SHIFT: + case BIT_AND: case BIT_XOR: case BIT_OR: + if (valuePtr->type != TYPE_INT) { + badType = valuePtr->type; + goto illegalType; + } else if (value2.type != TYPE_INT) { + badType = value2.type; + goto illegalType; + } + break; + + /* + * For the operators below, any type is allowed but the + * two operands must have the same type. Convert integers + * to floats and either to strings, if necessary. + */ + + case LESS: case GREATER: case LEQ: case GEQ: + case EQUAL: case NEQ: + if (valuePtr->type == TYPE_STRING) { + if (value2.type != TYPE_STRING) { + ExprMakeString(interp, &value2); + } + } else if (value2.type == TYPE_STRING) { + if (valuePtr->type != TYPE_STRING) { + ExprMakeString(interp, valuePtr); + } + } else if (valuePtr->type == TYPE_DOUBLE) { + if (value2.type == TYPE_INT) { + value2.doubleValue = value2.intValue; + value2.type = TYPE_DOUBLE; + } + } else if (value2.type == TYPE_DOUBLE) { + if (valuePtr->type == TYPE_INT) { + valuePtr->doubleValue = valuePtr->intValue; + valuePtr->type = TYPE_DOUBLE; + } + } + break; + + /* + * For the operators below, no strings are allowed, but + * no int->double conversions are performed. + */ + + case AND: case OR: + if (valuePtr->type == TYPE_STRING) { + badType = valuePtr->type; + goto illegalType; + } + if (value2.type == TYPE_STRING) { + badType = value2.type; + goto illegalType; + } + break; + + /* + * For the operators below, type and conversions are + * irrelevant: they're handled elsewhere. + */ + + case QUESTY: case COLON: + break; + + /* + * Any other operator is an error. + */ + + default: + interp->result = "unknown operator in expression"; + result = TCL_ERROR; + goto done; + } + + /* + * If necessary, convert one of the operands to the type + * of the other. If the operands are incompatible with + * the operator (e.g. "+" on strings) then return an + * error. + */ + + switch (operator) { + case MULT: + if (valuePtr->type == TYPE_INT) { + valuePtr->intValue *= value2.intValue; + } else { + valuePtr->doubleValue *= value2.doubleValue; + } + break; + case DIVIDE: + case MOD: + if (valuePtr->type == TYPE_INT) { + int divisor, quot, rem, negative; + if (value2.intValue == 0) { + divideByZero: + interp->result = "divide by zero"; + Tcl_SetErrorCode(interp, "ARITH", "DIVZERO", + interp->result, (char *) NULL); + result = TCL_ERROR; + goto done; + } + + /* + * The code below is tricky because C doesn't guarantee + * much about the properties of the quotient or + * remainder, but Tcl does: the remainder always has + * the same sign as the divisor and a smaller absolute + * value. + */ + + divisor = value2.intValue; + negative = 0; + if (divisor < 0) { + divisor = -divisor; + valuePtr->intValue = -valuePtr->intValue; + negative = 1; + } + quot = valuePtr->intValue / divisor; + rem = valuePtr->intValue % divisor; + if (rem < 0) { + rem += divisor; + quot -= 1; + } + if (negative) { + rem = -rem; + } + valuePtr->intValue = (operator == DIVIDE) ? quot : rem; + } else { + if (value2.doubleValue == 0.0) { + goto divideByZero; + } + valuePtr->doubleValue /= value2.doubleValue; + } + break; + case PLUS: + if (valuePtr->type == TYPE_INT) { + valuePtr->intValue += value2.intValue; + } else { + valuePtr->doubleValue += value2.doubleValue; + } + break; + case MINUS: + if (valuePtr->type == TYPE_INT) { + valuePtr->intValue -= value2.intValue; + } else { + valuePtr->doubleValue -= value2.doubleValue; + } + break; + case LEFT_SHIFT: + valuePtr->intValue <<= value2.intValue; + break; + case RIGHT_SHIFT: + /* + * The following code is a bit tricky: it ensures that + * right shifts propagate the sign bit even on machines + * where ">>" won't do it by default. + */ + + if (valuePtr->intValue < 0) { + valuePtr->intValue = + ~((~valuePtr->intValue) >> value2.intValue); + } else { + valuePtr->intValue >>= value2.intValue; + } + break; + case LESS: + if (valuePtr->type == TYPE_INT) { + valuePtr->intValue = + valuePtr->intValue < value2.intValue; + } else if (valuePtr->type == TYPE_DOUBLE) { + valuePtr->intValue = + valuePtr->doubleValue < value2.doubleValue; + } else { + valuePtr->intValue = + strcmp(valuePtr->pv.buffer, value2.pv.buffer) < 0; + } + valuePtr->type = TYPE_INT; + break; + case GREATER: + if (valuePtr->type == TYPE_INT) { + valuePtr->intValue = + valuePtr->intValue > value2.intValue; + } else if (valuePtr->type == TYPE_DOUBLE) { + valuePtr->intValue = + valuePtr->doubleValue > value2.doubleValue; + } else { + valuePtr->intValue = + strcmp(valuePtr->pv.buffer, value2.pv.buffer) > 0; + } + valuePtr->type = TYPE_INT; + break; + case LEQ: + if (valuePtr->type == TYPE_INT) { + valuePtr->intValue = + valuePtr->intValue <= value2.intValue; + } else if (valuePtr->type == TYPE_DOUBLE) { + valuePtr->intValue = + valuePtr->doubleValue <= value2.doubleValue; + } else { + valuePtr->intValue = + strcmp(valuePtr->pv.buffer, value2.pv.buffer) <= 0; + } + valuePtr->type = TYPE_INT; + break; + case GEQ: + if (valuePtr->type == TYPE_INT) { + valuePtr->intValue = + valuePtr->intValue >= value2.intValue; + } else if (valuePtr->type == TYPE_DOUBLE) { + valuePtr->intValue = + valuePtr->doubleValue >= value2.doubleValue; + } else { + valuePtr->intValue = + strcmp(valuePtr->pv.buffer, value2.pv.buffer) >= 0; + } + valuePtr->type = TYPE_INT; + break; + case EQUAL: + if (valuePtr->type == TYPE_INT) { + valuePtr->intValue = + valuePtr->intValue == value2.intValue; + } else if (valuePtr->type == TYPE_DOUBLE) { + valuePtr->intValue = + valuePtr->doubleValue == value2.doubleValue; + } else { + valuePtr->intValue = + strcmp(valuePtr->pv.buffer, value2.pv.buffer) == 0; + } + valuePtr->type = TYPE_INT; + break; + case NEQ: + if (valuePtr->type == TYPE_INT) { + valuePtr->intValue = + valuePtr->intValue != value2.intValue; + } else if (valuePtr->type == TYPE_DOUBLE) { + valuePtr->intValue = + valuePtr->doubleValue != value2.doubleValue; + } else { + valuePtr->intValue = + strcmp(valuePtr->pv.buffer, value2.pv.buffer) != 0; + } + valuePtr->type = TYPE_INT; + break; + case BIT_AND: + valuePtr->intValue &= value2.intValue; + break; + case BIT_XOR: + valuePtr->intValue ^= value2.intValue; + break; + case BIT_OR: + valuePtr->intValue |= value2.intValue; + break; + + /* + * For AND and OR, we know that the first value has already + * been converted to an integer. Thus we need only consider + * the possibility of int vs. double for the second value. + */ + + case AND: + if (value2.type == TYPE_DOUBLE) { + value2.intValue = value2.doubleValue != 0; + value2.type = TYPE_INT; + } + valuePtr->intValue = valuePtr->intValue && value2.intValue; + break; + case OR: + if (value2.type == TYPE_DOUBLE) { + value2.intValue = value2.doubleValue != 0; + value2.type = TYPE_INT; + } + valuePtr->intValue = valuePtr->intValue || value2.intValue; + break; + + case COLON: + interp->result = "can't have : operator without ? first"; + result = TCL_ERROR; + goto done; + } + } + + done: + if (value2.pv.buffer != value2.staticSpace) { + ckfree(value2.pv.buffer); + } + return result; + + syntaxError: + Tcl_AppendResult(interp, "syntax error in expression \"", + infoPtr->originalExpr, "\"", (char *) NULL); + result = TCL_ERROR; + goto done; + + illegalType: + Tcl_AppendResult(interp, "can't use ", (badType == TYPE_DOUBLE) ? + "floating-point value" : "non-numeric string", + " as operand of \"", operatorStrings[operator], "\"", + (char *) NULL); + result = TCL_ERROR; + goto done; +} + +/* + *-------------------------------------------------------------- + * + * ExprMakeString -- + * + * Convert a value from int or double representation to + * a string. + * + * Results: + * The information at *valuePtr gets converted to string + * format, if it wasn't that way already. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +static void +ExprMakeString(interp, valuePtr) + Tcl_Interp *interp; /* Interpreter to use for precision + * information. */ + register Value *valuePtr; /* Value to be converted. */ +{ + int shortfall; + + shortfall = 150 - (valuePtr->pv.end - valuePtr->pv.buffer); + if (shortfall > 0) { + (*valuePtr->pv.expandProc)(&valuePtr->pv, shortfall); + } + if (valuePtr->type == TYPE_INT) { + sprintf(valuePtr->pv.buffer, "%ld", valuePtr->intValue); + } else if (valuePtr->type == TYPE_DOUBLE) { + Tcl_PrintDouble(interp, valuePtr->doubleValue, valuePtr->pv.buffer); + } + valuePtr->type = TYPE_STRING; +} + +/* + *-------------------------------------------------------------- + * + * ExprTopLevel -- + * + * This procedure provides top-level functionality shared by + * procedures like Tcl_ExprInt, Tcl_ExprDouble, etc. + * + * Results: + * The result is a standard Tcl return value. If an error + * occurs then an error message is left in interp->result. + * The value of the expression is returned in *valuePtr, in + * whatever form it ends up in (could be string or integer + * or double). Caller may need to convert result. Caller + * is also responsible for freeing string memory in *valuePtr, + * if any was allocated. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +static int +ExprTopLevel(interp, string, valuePtr) + Tcl_Interp *interp; /* Context in which to evaluate the + * expression. */ + char *string; /* Expression to evaluate. */ + Value *valuePtr; /* Where to store result. Should + * not be initialized by caller. */ +{ + ExprInfo info; + int result; + + /* + * Create the math functions the first time an expression is + * evaluated. + */ + + if (!(((Interp *) interp)->flags & EXPR_INITIALIZED)) { + BuiltinFunc *funcPtr; + + ((Interp *) interp)->flags |= EXPR_INITIALIZED; + for (funcPtr = funcTable; funcPtr->name != NULL; + funcPtr++) { + Tcl_CreateMathFunc(interp, funcPtr->name, funcPtr->numArgs, + funcPtr->argTypes, funcPtr->proc, funcPtr->clientData); + } + } + + info.originalExpr = string; + info.expr = string; + valuePtr->pv.buffer = valuePtr->pv.next = valuePtr->staticSpace; + valuePtr->pv.end = valuePtr->pv.buffer + STATIC_STRING_SPACE - 1; + valuePtr->pv.expandProc = TclExpandParseValue; + valuePtr->pv.clientData = (ClientData) NULL; + + result = ExprGetValue(interp, &info, -1, valuePtr); + if (result != TCL_OK) { + return result; + } + if (info.token != END) { + Tcl_AppendResult(interp, "syntax error in expression \"", + string, "\"", (char *) NULL); + return TCL_ERROR; + } + if ((valuePtr->type == TYPE_DOUBLE) && (IS_NAN(valuePtr->doubleValue) + || IS_INF(valuePtr->doubleValue))) { + /* + * IEEE floating-point error. + */ + + ExprFloatError(interp, valuePtr->doubleValue); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * Tcl_ExprLong, Tcl_ExprDouble, Tcl_ExprBoolean -- + * + * Procedures to evaluate an expression and return its value + * in a particular form. + * + * Results: + * Each of the procedures below returns a standard Tcl result. + * If an error occurs then an error message is left in + * interp->result. Otherwise the value of the expression, + * in the appropriate form, is stored at *resultPtr. If + * the expression had a result that was incompatible with the + * desired form then an error is returned. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +int +Tcl_ExprLong(interp, string, ptr) + Tcl_Interp *interp; /* Context in which to evaluate the + * expression. */ + char *string; /* Expression to evaluate. */ + long *ptr; /* Where to store result. */ +{ + Value value; + int result; + + result = ExprTopLevel(interp, string, &value); + if (result == TCL_OK) { + if (value.type == TYPE_INT) { + *ptr = value.intValue; + } else if (value.type == TYPE_DOUBLE) { + *ptr = value.doubleValue; + } else { + interp->result = "expression didn't have numeric value"; + result = TCL_ERROR; + } + } + if (value.pv.buffer != value.staticSpace) { + ckfree(value.pv.buffer); + } + return result; +} + +int +Tcl_ExprDouble(interp, string, ptr) + Tcl_Interp *interp; /* Context in which to evaluate the + * expression. */ + char *string; /* Expression to evaluate. */ + double *ptr; /* Where to store result. */ +{ + Value value; + int result; + + result = ExprTopLevel(interp, string, &value); + if (result == TCL_OK) { + if (value.type == TYPE_INT) { + *ptr = value.intValue; + } else if (value.type == TYPE_DOUBLE) { + *ptr = value.doubleValue; + } else { + interp->result = "expression didn't have numeric value"; + result = TCL_ERROR; + } + } + if (value.pv.buffer != value.staticSpace) { + ckfree(value.pv.buffer); + } + return result; +} + +int +Tcl_ExprBoolean(interp, string, ptr) + Tcl_Interp *interp; /* Context in which to evaluate the + * expression. */ + char *string; /* Expression to evaluate. */ + int *ptr; /* Where to store 0/1 result. */ +{ + Value value; + int result; + + result = ExprTopLevel(interp, string, &value); + if (result == TCL_OK) { + if (value.type == TYPE_INT) { + *ptr = value.intValue != 0; + } else if (value.type == TYPE_DOUBLE) { + *ptr = value.doubleValue != 0.0; + } else { + result = Tcl_GetBoolean(interp, value.pv.buffer, ptr); + } + } + if (value.pv.buffer != value.staticSpace) { + ckfree(value.pv.buffer); + } + return result; +} + +/* + *-------------------------------------------------------------- + * + * Tcl_ExprString -- + * + * Evaluate an expression and return its value in string form. + * + * Results: + * A standard Tcl result. If the result is TCL_OK, then the + * interpreter's result is set to the string value of the + * expression. If the result is TCL_OK, then interp->result + * contains an error message. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +int +Tcl_ExprString(interp, string) + Tcl_Interp *interp; /* Context in which to evaluate the + * expression. */ + char *string; /* Expression to evaluate. */ +{ + Value value; + int result; + + result = ExprTopLevel(interp, string, &value); + if (result == TCL_OK) { + if (value.type == TYPE_INT) { + sprintf(interp->result, "%ld", value.intValue); + } else if (value.type == TYPE_DOUBLE) { + Tcl_PrintDouble(interp, value.doubleValue, interp->result); + } else { + if (value.pv.buffer != value.staticSpace) { + interp->result = value.pv.buffer; + interp->freeProc = (Tcl_FreeProc *) free; + value.pv.buffer = value.staticSpace; + } else { + Tcl_SetResult(interp, value.pv.buffer, TCL_VOLATILE); + } + } + } + if (value.pv.buffer != value.staticSpace) { + ckfree(value.pv.buffer); + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_CreateMathFunc -- + * + * Creates a new math function for expressions in a given + * interpreter. + * + * Results: + * None. + * + * Side effects: + * The function defined by "name" is created; if such a function + * already existed then its definition is overriden. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_CreateMathFunc(interp, name, numArgs, argTypes, proc, clientData) + Tcl_Interp *interp; /* Interpreter in which function is + * to be available. */ + char *name; /* Name of function (e.g. "sin"). */ + int numArgs; /* Nnumber of arguments required by + * function. */ + Tcl_ValueType *argTypes; /* Array of types acceptable for + * each argument. */ + Tcl_MathProc *proc; /* Procedure that implements the + * math function. */ + ClientData clientData; /* Additional value to pass to the + * function. */ +{ + Interp *iPtr = (Interp *) interp; + Tcl_HashEntry *hPtr; + MathFunc *mathFuncPtr; + int new, i; + + hPtr = Tcl_CreateHashEntry(&iPtr->mathFuncTable, name, &new); + if (new) { + Tcl_SetHashValue(hPtr, ckalloc(sizeof(MathFunc))); + } + mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr); + if (numArgs > MAX_MATH_ARGS) { + numArgs = MAX_MATH_ARGS; + } + mathFuncPtr->numArgs = numArgs; + for (i = 0; i < numArgs; i++) { + mathFuncPtr->argTypes[i] = argTypes[i]; + } + mathFuncPtr->proc = proc; + mathFuncPtr->clientData = clientData; +} + +/* + *---------------------------------------------------------------------- + * + * ExprMathFunc -- + * + * This procedure is invoked to parse a math function from an + * expression string, carry out the function, and return the + * value computed. + * + * Results: + * TCL_OK is returned if all went well and the function's value + * was computed successfully. If an error occurred, TCL_ERROR + * is returned and an error message is left in interp->result. + * After a successful return infoPtr has been updated to refer + * to the character just after the function call, the token is + * set to VALUE, and the value is stored in valuePtr. + * + * Side effects: + * Embedded commands could have arbitrary side-effects. + * + *---------------------------------------------------------------------- + */ + +static int +ExprMathFunc(interp, infoPtr, valuePtr) + Tcl_Interp *interp; /* Interpreter to use for error + * reporting. */ + register ExprInfo *infoPtr; /* Describes the state of the parse. + * infoPtr->expr must point to the + * first character of the function's + * name. */ + register Value *valuePtr; /* Where to store value, if that is + * what's parsed from string. Caller + * must have initialized pv field + * correctly. */ +{ + Interp *iPtr = (Interp *) interp; + MathFunc *mathFuncPtr; /* Info about math function. */ + Tcl_Value args[MAX_MATH_ARGS]; /* Arguments for function call. */ + Tcl_Value funcResult; /* Result of function call. */ + Tcl_HashEntry *hPtr; + char *p, *funcName; + int i, savedChar, result; + + /* + * Find the end of the math function's name and lookup the MathFunc + * record for the function. + */ + + p = funcName = infoPtr->expr; + while (isalnum(UCHAR(*p)) || (*p == '_')) { + p++; + } + infoPtr->expr = p; + result = ExprLex(interp, infoPtr, valuePtr); + if ((result != TCL_OK) || (infoPtr->token != OPEN_PAREN)) { + goto syntaxError; + } + savedChar = *p; + *p = 0; + hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable, funcName); + if (hPtr == NULL) { + Tcl_AppendResult(interp, "unknown math function \"", funcName, + "\"", (char *) NULL); + *p = savedChar; + return TCL_ERROR; + } + *p = savedChar; + mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr); + + /* + * Scan off the arguments for the function, if there are any. + */ + + if (mathFuncPtr->numArgs == 0) { + result = ExprLex(interp, infoPtr, valuePtr); + if ((result != TCL_OK) || (infoPtr->token != CLOSE_PAREN)) { + goto syntaxError; + } + } else { + for (i = 0; ; i++) { + valuePtr->pv.next = valuePtr->pv.buffer; + result = ExprGetValue(interp, infoPtr, -1, valuePtr); + if (result != TCL_OK) { + return result; + } + if (valuePtr->type == TYPE_STRING) { + interp->result = + "argument to math function didn't have numeric value"; + return TCL_ERROR; + } + + /* + * Copy the value to the argument record, converting it if + * necessary. + */ + + if (valuePtr->type == TYPE_INT) { + if (mathFuncPtr->argTypes[i] == TCL_DOUBLE) { + args[i].type = TCL_DOUBLE; + args[i].doubleValue = valuePtr->intValue; + } else { + args[i].type = TCL_INT; + args[i].intValue = valuePtr->intValue; + } + } else { + if (mathFuncPtr->argTypes[i] == TCL_INT) { + args[i].type = TCL_INT; + args[i].intValue = valuePtr->doubleValue; + } else { + args[i].type = TCL_DOUBLE; + args[i].doubleValue = valuePtr->doubleValue; + } + } + + /* + * Check for a comma separator between arguments or a close-paren + * to end the argument list. + */ + + if (i == (mathFuncPtr->numArgs-1)) { + if (infoPtr->token == CLOSE_PAREN) { + break; + } + if (infoPtr->token == COMMA) { + interp->result = "too many arguments for math function"; + return TCL_ERROR; + } else { + goto syntaxError; + } + } + if (infoPtr->token != COMMA) { + if (infoPtr->token == CLOSE_PAREN) { + interp->result = "too few arguments for math function"; + return TCL_ERROR; + } else { + goto syntaxError; + } + } + } + } + + /* + * Invoke the function and copy its result back into valuePtr. + */ + + tcl_MathInProgress++; + result = (*mathFuncPtr->proc)(mathFuncPtr->clientData, interp, args, + &funcResult); + tcl_MathInProgress--; + if (result != TCL_OK) { + return result; + } + if (funcResult.type == TCL_INT) { + valuePtr->type = TYPE_INT; + valuePtr->intValue = funcResult.intValue; + } else { + valuePtr->type = TYPE_DOUBLE; + valuePtr->doubleValue = funcResult.doubleValue; + } + infoPtr->token = VALUE; + return TCL_OK; + + syntaxError: + Tcl_AppendResult(interp, "syntax error in expression \"", + infoPtr->originalExpr, "\"", (char *) NULL); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * ExprFloatError -- + * + * This procedure is called when an error occurs during a + * floating-point operation. It reads errno and sets + * interp->result accordingly. + * + * Results: + * Interp->result is set to hold an error message. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static void +ExprFloatError(interp, value) + Tcl_Interp *interp; /* Where to store error message. */ + double value; /* Value returned after error; used to + * distinguish underflows from overflows. */ +{ + char buf[20]; + + if ((errno == EDOM) || (value != value)) { + interp->result = "domain error: argument not in valid range"; + Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", interp->result, + (char *) NULL); + } else if ((errno == ERANGE) || IS_INF(value)) { + if (value == 0.0) { + interp->result = "floating-point value too small to represent"; + Tcl_SetErrorCode(interp, "ARITH", "UNDERFLOW", interp->result, + (char *) NULL); + } else { + interp->result = "floating-point value too large to represent"; + Tcl_SetErrorCode(interp, "ARITH", "OVERFLOW", interp->result, + (char *) NULL); + } + } else { + sprintf(buf, "%d", errno); + Tcl_AppendResult(interp, "unknown floating-point error, ", + "errno = ", buf, (char *) NULL); + Tcl_SetErrorCode(interp, "ARITH", "UNKNOWN", interp->result, + (char *) NULL); + } +} + +/* + *---------------------------------------------------------------------- + * + * Math Functions -- + * + * This page contains the procedures that implement all of the + * built-in math functions for expressions. + * + * Results: + * Each procedure returns TCL_OK if it succeeds and places result + * information at *resultPtr. If it fails it returns TCL_ERROR + * and leaves an error message in interp->result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +ExprUnaryFunc(clientData, interp, args, resultPtr) + ClientData clientData; /* Contains address of procedure that + * takes one double argument and + * returns a double result. */ + Tcl_Interp *interp; + Tcl_Value *args; + Tcl_Value *resultPtr; +{ + double (*func)() = (double (*)()) clientData; + + errno = 0; + resultPtr->type = TCL_DOUBLE; + resultPtr->doubleValue = (*func)(args[0].doubleValue); + if (errno != 0) { + ExprFloatError(interp, resultPtr->doubleValue); + return TCL_ERROR; + } + return TCL_OK; +} + +static int +ExprBinaryFunc(clientData, interp, args, resultPtr) + ClientData clientData; /* Contains address of procedure that + * takes two double arguments and + * returns a double result. */ + Tcl_Interp *interp; + Tcl_Value *args; + Tcl_Value *resultPtr; +{ + double (*func)() = (double (*)()) clientData; + + errno = 0; + resultPtr->type = TCL_DOUBLE; + resultPtr->doubleValue = (*func)(args[0].doubleValue, args[1].doubleValue); + if (errno != 0) { + ExprFloatError(interp, resultPtr->doubleValue); + return TCL_ERROR; + } + return TCL_OK; +} + + /* ARGSUSED */ +static int +ExprAbsFunc(clientData, interp, args, resultPtr) + ClientData clientData; + Tcl_Interp *interp; + Tcl_Value *args; + Tcl_Value *resultPtr; +{ + resultPtr->type = TCL_DOUBLE; + if (args[0].type == TCL_DOUBLE) { + resultPtr->type = TCL_DOUBLE; + if (args[0].doubleValue < 0) { + resultPtr->doubleValue = -args[0].doubleValue; + } else { + resultPtr->doubleValue = args[0].doubleValue; + } + } else { + resultPtr->type = TCL_INT; + if (args[0].intValue < 0) { + resultPtr->intValue = -args[0].intValue; + if (resultPtr->intValue < 0) { + interp->result = "integer value too large to represent"; + Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", interp->result, + (char *) NULL); + return TCL_ERROR; + } + } else { + resultPtr->intValue = args[0].intValue; + } + } + return TCL_OK; +} + + /* ARGSUSED */ +static int +ExprDoubleFunc(clientData, interp, args, resultPtr) + ClientData clientData; + Tcl_Interp *interp; + Tcl_Value *args; + Tcl_Value *resultPtr; +{ + resultPtr->type = TCL_DOUBLE; + if (args[0].type == TCL_DOUBLE) { + resultPtr->doubleValue = args[0].doubleValue; + } else { + resultPtr->doubleValue = args[0].intValue; + } + return TCL_OK; +} + + /* ARGSUSED */ +static int +ExprIntFunc(clientData, interp, args, resultPtr) + ClientData clientData; + Tcl_Interp *interp; + Tcl_Value *args; + Tcl_Value *resultPtr; +{ + resultPtr->type = TCL_INT; + if (args[0].type == TCL_INT) { + resultPtr->intValue = args[0].intValue; + } else { + if (args[0].doubleValue < 0) { + if (args[0].doubleValue < (double) (long) LONG_MIN) { + tooLarge: + interp->result = "integer value too large to represent"; + Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", + interp->result, (char *) NULL); + return TCL_ERROR; + } + } else { + if (args[0].doubleValue > (double) LONG_MAX) { + goto tooLarge; + } + } + resultPtr->intValue = args[0].doubleValue; + } + return TCL_OK; +} + + /* ARGSUSED */ +static int +ExprRoundFunc(clientData, interp, args, resultPtr) + ClientData clientData; + Tcl_Interp *interp; + Tcl_Value *args; + Tcl_Value *resultPtr; +{ + resultPtr->type = TCL_INT; + if (args[0].type == TCL_INT) { + resultPtr->intValue = args[0].intValue; + } else { + if (args[0].doubleValue < 0) { + if (args[0].doubleValue <= (((double) (long) LONG_MIN) - 0.5)) { + tooLarge: + interp->result = "integer value too large to represent"; + Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", + interp->result, (char *) NULL); + return TCL_ERROR; + } + resultPtr->intValue = (args[0].doubleValue - 0.5); + } else { + if (args[0].doubleValue >= (((double) LONG_MAX + 0.5))) { + goto tooLarge; + } + resultPtr->intValue = (args[0].doubleValue + 0.5); + } + } + return TCL_OK; +} diff --git a/vendor/x11iraf/obm/Tcl/tclGet.c b/vendor/x11iraf/obm/Tcl/tclGet.c new file mode 100644 index 00000000..fe280e6b --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/tclGet.c @@ -0,0 +1,210 @@ +/* + * tclGet.c -- + * + * This file contains procedures to convert strings into + * other forms, like integers or floating-point numbers or + * booleans, doing syntax checking along the way. + * + * Copyright (c) 1990-1993 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. + */ + +#ifndef lint +static char rcsid[] = "$Header: /user6/ouster/tcl/RCS/tclGet.c,v 1.14 93/08/18 16:07:24 ouster Exp $ SPRITE (Berkeley)"; +#endif /* not lint */ + +#include "tclInt.h" + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetInt -- + * + * Given a string, produce the corresponding integer value. + * + * Results: + * The return value is normally TCL_OK; in this case *intPtr + * will be set to the integer value equivalent to string. If + * string is improperly formed then TCL_ERROR is returned and + * an error message will be left in interp->result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_GetInt(interp, string, intPtr) + Tcl_Interp *interp; /* Interpreter to use for error reporting. */ + char *string; /* String containing a (possibly signed) + * integer in a form acceptable to strtol. */ + int *intPtr; /* Place to store converted result. */ +{ + 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. + */ + + for (p = string; isspace(UCHAR(*p)); p++) { + /* Empty loop body. */ + } + if (*p == '-') { + i = -strtoul(p+1, &end, 0); + } else if (*p == '+') { + i = strtoul(p+1, &end, 0); + } else { + i = strtoul(p, &end, 0); + } + while ((*end != '\0') && isspace(UCHAR(*end))) { + end++; + } + if ((end == string) || (*end != 0)) { + Tcl_AppendResult(interp, "expected integer but got \"", string, + "\"", (char *) NULL); + return TCL_ERROR; + } + *intPtr = i; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetDouble -- + * + * Given a string, produce the corresponding double-precision + * floating-point value. + * + * Results: + * The return value is normally TCL_OK; in this case *doublePtr + * will be set to the double-precision value equivalent to string. + * If string is improperly formed then TCL_ERROR is returned and + * an error message will be left in interp->result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_GetDouble(interp, string, doublePtr) + Tcl_Interp *interp; /* Interpreter to use for error reporting. */ + char *string; /* String containing a floating-point number + * in a form acceptable to strtod. */ + double *doublePtr; /* Place to store converted result. */ +{ + char *end; + double d; + + d = strtod(string, &end); + while ((*end != '\0') && isspace(UCHAR(*end))) { + end++; + } + if ((end == string) || (*end != 0)) { + Tcl_AppendResult(interp, "expected floating-point number but got \"", + string, "\"", (char *) NULL); + return TCL_ERROR; + } + *doublePtr = d; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetBoolean -- + * + * Given a string, return a 0/1 boolean value corresponding + * to the string. + * + * Results: + * The return value is normally TCL_OK; in this case *boolPtr + * will be set to the 0/1 value equivalent to string. If + * string is improperly formed then TCL_ERROR is returned and + * an error message will be left in interp->result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_GetBoolean(interp, string, boolPtr) + Tcl_Interp *interp; /* Interpreter to use for error reporting. */ + char *string; /* String containing a boolean number + * specified either as 1/0 or true/false or + * yes/no. */ + int *boolPtr; /* Place to store converted result, which + * will be 0 or 1. */ +{ + char c; + char lowerCase[10]; + int i, length; + + /* + * Convert the input string to all lower-case. + */ + + for (i = 0; i < 9; i++) { + c = string[i]; + if (c == 0) { + break; + } + if ((c >= 'A') && (c <= 'Z')) { + c += 'a' - 'A'; + } + lowerCase[i] = c; + } + lowerCase[i] = 0; + + length = strlen(lowerCase); + c = lowerCase[0]; + if ((c == '0') && (lowerCase[1] == '\0')) { + *boolPtr = 0; + } else if ((c == '1') && (lowerCase[1] == '\0')) { + *boolPtr = 1; + } else if ((c == 'y') && (strncmp(lowerCase, "yes", length) == 0)) { + *boolPtr = 1; + } else if ((c == 'n') && (strncmp(lowerCase, "no", length) == 0)) { + *boolPtr = 0; + } else if ((c == 't') && (strncmp(lowerCase, "true", length) == 0)) { + *boolPtr = 1; + } else if ((c == 'f') && (strncmp(lowerCase, "false", length) == 0)) { + *boolPtr = 0; + } else if ((c == 'o') && (length >= 2)) { + if (strncmp(lowerCase, "on", length) == 0) { + *boolPtr = 1; + } else if (strncmp(lowerCase, "off", length) == 0) { + *boolPtr = 0; + } + } else { + Tcl_AppendResult(interp, "expected boolean value but got \"", + string, "\"", (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} diff --git a/vendor/x11iraf/obm/Tcl/tclGlob.c b/vendor/x11iraf/obm/Tcl/tclGlob.c new file mode 100644 index 00000000..a7f29d3d --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/tclGlob.c @@ -0,0 +1,455 @@ +/* + * tclGlob.c -- + * + * This file provides procedures and commands for file name + * manipulation, such as tilde expansion and globbing. + * + * Copyright (c) 1990-1993 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. + */ + +#ifndef lint +static char rcsid[] = "$Header: /user6/ouster/tcl/RCS/tclGlob.c,v 1.36 93/10/14 15:14:08 ouster Exp $ SPRITE (Berkeley)"; +#endif /* not lint */ + +#include "tclInt.h" +#include "tclUnix.h" + +/* + * The structure below is used to keep track of a globbing result + * being built up (i.e. a partial list of file names). The list + * grows dynamically to be as big as needed. + */ + +typedef struct { + char *result; /* Pointer to result area. */ + int totalSpace; /* Total number of characters allocated + * for result. */ + int spaceUsed; /* Number of characters currently in use + * to hold the partial result (not including + * the terminating NULL). */ + int dynamic; /* 0 means result is static space, 1 means + * it's dynamic. */ +} GlobResult; + +/* + * Declarations for procedures local to this file: + */ + +static int DoGlob _ANSI_ARGS_((Tcl_Interp *interp, char *dir, + char *rem)); + +/* + *---------------------------------------------------------------------- + * + * DoGlob -- + * + * This recursive procedure forms the heart of the globbing + * code. It performs a depth-first traversal of the tree + * given by the path name to be globbed. + * + * Results: + * The return value is a standard Tcl result indicating whether + * an error occurred in globbing. After a normal return the + * result in interp will be set to hold all of the file names + * given by the dir and rem arguments. After an error the + * result in interp will hold an error message. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +DoGlob(interp, dir, rem) + Tcl_Interp *interp; /* Interpreter to use for error + * reporting (e.g. unmatched brace). */ + char *dir; /* Name of a directory at which to + * start glob expansion. This name + * is fixed: it doesn't contain any + * globbing chars. */ + char *rem; /* Path to glob-expand. */ +{ + /* + * When this procedure is entered, the name to be globbed may + * already have been partly expanded by ancestor invocations of + * DoGlob. The part that's already been expanded is in "dir" + * (this may initially be empty), and the part still to expand + * is in "rem". This procedure expands "rem" one level, making + * recursive calls to itself if there's still more stuff left + * in the remainder. + */ + + Tcl_DString newName; /* Holds new name consisting of + * dir plus the first part of rem. */ + register char *p; + register char c; + char *openBrace, *closeBrace, *name, *dirName; + int gotSpecial, baseLength; + int result = TCL_OK; + struct stat statBuf; + + /* + * Make sure that the directory part of the name really is a + * directory. If the directory name is "", use the name "." + * instead, because some UNIX systems don't treat "" like "." + * automatically. Keep the "" for use in generating file names, + * otherwise "glob foo.c" would return "./foo.c". + */ + + if (*dir == '\0') { + dirName = "."; + } else { + dirName = dir; + } + if ((stat(dirName, &statBuf) != 0) || !S_ISDIR(statBuf.st_mode)) { + return TCL_OK; + } + Tcl_DStringInit(&newName); + + /* + * First, find the end of the next element in rem, checking + * along the way for special globbing characters. + */ + + gotSpecial = 0; + openBrace = closeBrace = NULL; + for (p = rem; ; p++) { + c = *p; + if ((c == '\0') || ((openBrace == NULL) && (c == '/'))) { + break; + } + if ((c == '{') && (openBrace == NULL)) { + openBrace = p; + } + if ((c == '}') && (openBrace != NULL) && (closeBrace == NULL)) { + closeBrace = p; + } + if ((c == '*') || (c == '[') || (c == '\\') || (c == '?')) { + gotSpecial = 1; + } + } + + /* + * If there is an open brace in the argument, then make a recursive + * call for each element between the braces. In this case, the + * recursive call to DoGlob uses the same "dir" that we got. + * If there are several brace-pairs in a single name, we just handle + * one here, and the others will be handled in recursive calls. + */ + + if (openBrace != NULL) { + char *element; + + if (closeBrace == NULL) { + Tcl_ResetResult(interp); + interp->result = "unmatched open-brace in file name"; + result = TCL_ERROR; + goto done; + } + Tcl_DStringAppend(&newName, rem, openBrace-rem); + baseLength = newName.length; + for (p = openBrace; *p != '}'; ) { + element = p+1; + for (p = element; ((*p != '}') && (*p != ',')); p++) { + /* Empty loop body. */ + } + Tcl_DStringAppend(&newName, element, p-element); + Tcl_DStringAppend(&newName, closeBrace+1, -1); + result = DoGlob(interp, dir, newName.string); + if (result != TCL_OK) { + goto done; + } + newName.length = baseLength; + } + goto done; + } + + /* + * Start building up the next-level name with dir plus a slash if + * needed to separate it from the next file name. + */ + + Tcl_DStringAppend(&newName, dir, -1); + if ((dir[0] != 0) && (newName.string[newName.length-1] != '/')) { + Tcl_DStringAppend(&newName, "/", 1); + } + baseLength = newName.length; + + /* + * If there were any pattern-matching characters, then scan through + * the directory to find all the matching names. + */ + + if (gotSpecial) { + DIR *d; + struct dirent *entryPtr; + char savedChar; + + d = opendir(dirName); + if (d == NULL) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "couldn't read directory \"", + dirName, "\": ", Tcl_PosixError(interp), (char *) NULL); + result = TCL_ERROR; + goto done; + } + + /* + * Temporarily store a null into rem so that the pattern string + * is now null-terminated. + */ + + savedChar = *p; + *p = 0; + + while (1) { + entryPtr = readdir(d); + if (entryPtr == NULL) { + break; + } + + /* + * Don't match names starting with "." unless the "." is + * present in the pattern. + */ + + if ((*entryPtr->d_name == '.') && (*rem != '.')) { + continue; + } + if (Tcl_StringMatch(entryPtr->d_name, rem)) { + newName.length = baseLength; + Tcl_DStringAppend(&newName, entryPtr->d_name, -1); + if (savedChar == 0) { + Tcl_AppendElement(interp, newName.string); + } else { + result = DoGlob(interp, newName.string, p+1); + if (result != TCL_OK) { + break; + } + } + } + } + closedir(d); + *p = savedChar; + goto done; + } + + /* + * The current element is a simple one with no fancy features. Add + * it to the new name. If there are more elements still to come, + * then recurse to process them. + */ + + Tcl_DStringAppend(&newName, rem, p-rem); + if (*p != 0) { + result = DoGlob(interp, newName.string, p+1); + goto done; + } + + /* + * There are no more elements in the pattern. Check to be sure the + * file actually exists, then add its name to the list being formed + * in interp-result. + */ + + name = newName.string; + if (*name == 0) { + name = "."; + } + if (access(name, F_OK) != 0) { + goto done; + } + Tcl_AppendElement(interp, name); + + done: + Tcl_DStringFree(&newName); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_TildeSubst -- + * + * Given a name starting with a tilde, produce a name where + * the tilde and following characters have been replaced by + * the home directory location for the named user. + * + * Results: + * The result is a pointer to a static string containing + * the new name. If there was an error in processing the + * tilde, then an error message is left in interp->result + * and the return value is NULL. The result may be stored + * in bufferPtr; the caller must call Tcl_DStringFree(bufferPtr) + * to free the name. + * + * Side effects: + * Information may be left in bufferPtr. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_TildeSubst(interp, name, bufferPtr) + Tcl_Interp *interp; /* Interpreter in which to store error + * message (if necessary). */ + char *name; /* File name, which may begin with "~/" + * (to indicate current user's home directory) + * or "~<user>/" (to indicate any user's + * home directory). */ + Tcl_DString *bufferPtr; /* May be used to hold result. Must not hold + * anything at the time of the call, and need + * not even be initialized. */ +{ + char *dir; + register char *p; + + Tcl_DStringInit(bufferPtr); + if (name[0] != '~') { + return name; + } + + if ((name[1] == '/') || (name[1] == '\0')) { + dir = getenv("HOME"); + if (dir == NULL) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "couldn't find HOME environment ", + "variable to expand \"", name, "\"", (char *) NULL); + return NULL; + } + Tcl_DStringAppend(bufferPtr, dir, -1); + Tcl_DStringAppend(bufferPtr, name+1, -1); + } else { + struct passwd *pwPtr; + + for (p = &name[1]; (*p != 0) && (*p != '/'); p++) { + /* Null body; just find end of name. */ + } + Tcl_DStringAppend(bufferPtr, name+1, p - (name+1)); + pwPtr = getpwnam(bufferPtr->string); + if (pwPtr == NULL) { + endpwent(); + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "user \"", bufferPtr->string, + "\" doesn't exist", (char *) NULL); + return NULL; + } + Tcl_DStringFree(bufferPtr); + Tcl_DStringAppend(bufferPtr, pwPtr->pw_dir, -1); + Tcl_DStringAppend(bufferPtr, p, -1); + endpwent(); + } + return bufferPtr->string; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GlobCmd -- + * + * This procedure is invoked to process the "glob" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_GlobCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int i, result, noComplain, firstArg; + + if (argc < 2) { + notEnoughArgs: + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " ?switches? name ?name ...?\"", (char *) NULL); + return TCL_ERROR; + } + noComplain = 0; + for (firstArg = 1; (firstArg < argc) && (argv[firstArg][0] == '-'); + firstArg++) { + if (strcmp(argv[firstArg], "-nocomplain") == 0) { + noComplain = 1; + } else if (strcmp(argv[firstArg], "--") == 0) { + firstArg++; + break; + } else { + Tcl_AppendResult(interp, "bad switch \"", argv[firstArg], + "\": must be -nocomplain or --", (char *) NULL); + return TCL_ERROR; + } + } + if (firstArg >= argc) { + goto notEnoughArgs; + } + + for (i = firstArg; i < argc; i++) { + char *thisName; + Tcl_DString buffer; + + thisName = Tcl_TildeSubst(interp, argv[i], &buffer); + if (thisName == NULL) { + return TCL_ERROR; + } + if (*thisName == '/') { + if (thisName[1] == '/') { + /* + * This is a special hack for systems like those from Apollo + * where there is a super-root at "//": need to treat the + * double-slash as a single name. + */ + result = DoGlob(interp, "//", thisName+2); + } else { + result = DoGlob(interp, "/", thisName+1); + } + } else { + result = DoGlob(interp, "", thisName); + } + Tcl_DStringFree(&buffer); + if (result != TCL_OK) { + return result; + } + } + if ((*interp->result == 0) && !noComplain) { + char *sep = ""; + + Tcl_AppendResult(interp, "no files matched glob pattern", + (argc == 2) ? " \"" : "s \"", (char *) NULL); + for (i = firstArg; i < argc; i++) { + Tcl_AppendResult(interp, sep, argv[i], (char *) NULL); + sep = " "; + } + Tcl_AppendResult(interp, "\"", (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} diff --git a/vendor/x11iraf/obm/Tcl/tclHash.c b/vendor/x11iraf/obm/Tcl/tclHash.c new file mode 100644 index 00000000..1c4ac37c --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/tclHash.c @@ -0,0 +1,937 @@ +/* + * tclHash.c -- + * + * Implementation of in-memory hash tables for Tcl and Tcl-based + * applications. + * + * Copyright (c) 1991-1993 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. + */ + +#ifndef lint +static char rcsid[] = "$Header: /user6/ouster/tcl/RCS/tclHash.c,v 1.13 93/06/02 10:17:13 ouster Exp $ SPRITE (Berkeley)"; +#endif /* not lint */ + +#include "tclInt.h" + +/* + * When there are this many entries per bucket, on average, rebuild + * the hash table to make it larger. + */ + +#define REBUILD_MULTIPLIER 3 + + +/* + * The following macro takes a preliminary integer hash value and + * produces an index into a hash tables bucket list. The idea is + * to make it so that preliminary values that are arbitrarily similar + * will end up in different buckets. The hash function was taken + * from a random-number generator. + */ + +#define RANDOM_INDEX(tablePtr, i) \ + (((((long) (i))*1103515245) >> (tablePtr)->downShift) & (tablePtr)->mask) + +/* + * Procedure prototypes for static procedures in this file: + */ + +static Tcl_HashEntry * ArrayFind _ANSI_ARGS_((Tcl_HashTable *tablePtr, + char *key)); +static Tcl_HashEntry * ArrayCreate _ANSI_ARGS_((Tcl_HashTable *tablePtr, + char *key, int *newPtr)); +static Tcl_HashEntry * BogusFind _ANSI_ARGS_((Tcl_HashTable *tablePtr, + char *key)); +static Tcl_HashEntry * BogusCreate _ANSI_ARGS_((Tcl_HashTable *tablePtr, + char *key, int *newPtr)); +static unsigned int HashString _ANSI_ARGS_((char *string)); +static void RebuildTable _ANSI_ARGS_((Tcl_HashTable *tablePtr)); +static Tcl_HashEntry * StringFind _ANSI_ARGS_((Tcl_HashTable *tablePtr, + char *key)); +static Tcl_HashEntry * StringCreate _ANSI_ARGS_((Tcl_HashTable *tablePtr, + char *key, int *newPtr)); +static Tcl_HashEntry * OneWordFind _ANSI_ARGS_((Tcl_HashTable *tablePtr, + char *key)); +static Tcl_HashEntry * OneWordCreate _ANSI_ARGS_((Tcl_HashTable *tablePtr, + char *key, int *newPtr)); + +/* + *---------------------------------------------------------------------- + * + * Tcl_InitHashTable -- + * + * Given storage for a hash table, set up the fields to prepare + * the hash table for use. + * + * Results: + * None. + * + * Side effects: + * TablePtr is now ready to be passed to Tcl_FindHashEntry and + * Tcl_CreateHashEntry. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_InitHashTable(tablePtr, keyType) + register Tcl_HashTable *tablePtr; /* Pointer to table record, which + * is supplied by the caller. */ + int keyType; /* Type of keys to use in table: + * TCL_STRING_KEYS, TCL_ONE_WORD_KEYS, + * or an integer >= 2. */ +{ + tablePtr->buckets = tablePtr->staticBuckets; + tablePtr->staticBuckets[0] = tablePtr->staticBuckets[1] = 0; + tablePtr->staticBuckets[2] = tablePtr->staticBuckets[3] = 0; + tablePtr->numBuckets = TCL_SMALL_HASH_TABLE; + tablePtr->numEntries = 0; + tablePtr->rebuildSize = TCL_SMALL_HASH_TABLE*REBUILD_MULTIPLIER; + tablePtr->downShift = 28; + tablePtr->mask = 3; + tablePtr->keyType = keyType; + if (keyType == TCL_STRING_KEYS) { + tablePtr->findProc = StringFind; + tablePtr->createProc = StringCreate; + } else if (keyType == TCL_ONE_WORD_KEYS) { + tablePtr->findProc = OneWordFind; + tablePtr->createProc = OneWordCreate; + } else { + tablePtr->findProc = ArrayFind; + tablePtr->createProc = ArrayCreate; + }; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DeleteHashEntry -- + * + * Remove a single entry from a hash table. + * + * Results: + * None. + * + * Side effects: + * The entry given by entryPtr is deleted from its table and + * should never again be used by the caller. It is up to the + * caller to free the clientData field of the entry, if that + * is relevant. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DeleteHashEntry(entryPtr) + Tcl_HashEntry *entryPtr; +{ + register Tcl_HashEntry *prevPtr; + + if (*entryPtr->bucketPtr == entryPtr) { + *entryPtr->bucketPtr = entryPtr->nextPtr; + } else { + for (prevPtr = *entryPtr->bucketPtr; ; prevPtr = prevPtr->nextPtr) { + if (prevPtr == NULL) { + panic("malformed bucket chain in Tcl_DeleteHashEntry"); + } + if (prevPtr->nextPtr == entryPtr) { + prevPtr->nextPtr = entryPtr->nextPtr; + break; + } + } + } + entryPtr->tablePtr->numEntries--; + ckfree((char *) entryPtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DeleteHashTable -- + * + * Free up everything associated with a hash table except for + * the record for the table itself. + * + * Results: + * None. + * + * Side effects: + * The hash table is no longer useable. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DeleteHashTable(tablePtr) + register Tcl_HashTable *tablePtr; /* Table to delete. */ +{ + register Tcl_HashEntry *hPtr, *nextPtr; + int i; + + /* + * Free up all the entries in the table. + */ + + for (i = 0; i < tablePtr->numBuckets; i++) { + hPtr = tablePtr->buckets[i]; + while (hPtr != NULL) { + nextPtr = hPtr->nextPtr; + ckfree((char *) hPtr); + hPtr = nextPtr; + } + } + + /* + * Free up the bucket array, if it was dynamically allocated. + */ + + if (tablePtr->buckets != tablePtr->staticBuckets) { + ckfree((char *) tablePtr->buckets); + } + + /* + * Arrange for panics if the table is used again without + * re-initialization. + */ + + tablePtr->findProc = BogusFind; + tablePtr->createProc = BogusCreate; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_FirstHashEntry -- + * + * Locate the first entry in a hash table and set up a record + * that can be used to step through all the remaining entries + * of the table. + * + * Results: + * The return value is a pointer to the first entry in tablePtr, + * or NULL if tablePtr has no entries in it. The memory at + * *searchPtr is initialized so that subsequent calls to + * Tcl_NextHashEntry will return all of the entries in the table, + * one at a time. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_HashEntry * +Tcl_FirstHashEntry(tablePtr, searchPtr) + Tcl_HashTable *tablePtr; /* Table to search. */ + Tcl_HashSearch *searchPtr; /* Place to store information about + * progress through the table. */ +{ + searchPtr->tablePtr = tablePtr; + searchPtr->nextIndex = 0; + searchPtr->nextEntryPtr = NULL; + return Tcl_NextHashEntry(searchPtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_NextHashEntry -- + * + * Once a hash table enumeration has been initiated by calling + * Tcl_FirstHashEntry, this procedure may be called to return + * successive elements of the table. + * + * Results: + * The return value is the next entry in the hash table being + * enumerated, or NULL if the end of the table is reached. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_HashEntry * +Tcl_NextHashEntry(searchPtr) + register Tcl_HashSearch *searchPtr; /* Place to store information about + * progress through the table. Must + * have been initialized by calling + * Tcl_FirstHashEntry. */ +{ + Tcl_HashEntry *hPtr; + + while (searchPtr->nextEntryPtr == NULL) { + if (searchPtr->nextIndex >= searchPtr->tablePtr->numBuckets) { + return NULL; + } + searchPtr->nextEntryPtr = + searchPtr->tablePtr->buckets[searchPtr->nextIndex]; + searchPtr->nextIndex++; + } + hPtr = searchPtr->nextEntryPtr; + searchPtr->nextEntryPtr = hPtr->nextPtr; + return hPtr; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_HashStats -- + * + * Return statistics describing the layout of the hash table + * in its hash buckets. + * + * Results: + * The return value is a malloc-ed string containing information + * about tablePtr. It is the caller's responsibility to free + * this string. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_HashStats(tablePtr) + Tcl_HashTable *tablePtr; /* Table for which to produce stats. */ +{ +#define NUM_COUNTERS 10 + int count[NUM_COUNTERS], overflow, i, j; + double average, tmp; + register Tcl_HashEntry *hPtr; + char *result, *p; + + /* + * Compute a histogram of bucket usage. + */ + + for (i = 0; i < NUM_COUNTERS; i++) { + count[i] = 0; + } + overflow = 0; + average = 0.0; + for (i = 0; i < tablePtr->numBuckets; i++) { + j = 0; + for (hPtr = tablePtr->buckets[i]; hPtr != NULL; hPtr = hPtr->nextPtr) { + j++; + } + if (j < NUM_COUNTERS) { + count[j]++; + } else { + overflow++; + } + tmp = j; + average += (tmp+1.0)*(tmp/tablePtr->numEntries)/2.0; + } + + /* + * Print out the histogram and a few other pieces of information. + */ + + result = (char *) ckalloc((unsigned) ((NUM_COUNTERS*60) + 300)); + sprintf(result, "%d entries in table, %d buckets\n", + tablePtr->numEntries, tablePtr->numBuckets); + p = result + strlen(result); + for (i = 0; i < NUM_COUNTERS; i++) { + sprintf(p, "number of buckets with %d entries: %d\n", + i, count[i]); + p += strlen(p); + } + sprintf(p, "number of buckets with %d or more entries: %d\n", + NUM_COUNTERS, overflow); + p += strlen(p); + sprintf(p, "average search distance for entry: %.1f", average); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * HashString -- + * + * Compute a one-word summary of a text string, which can be + * used to generate a hash index. + * + * Results: + * The return value is a one-word summary of the information in + * string. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static unsigned int +HashString(string) + register char *string; /* String from which to compute hash value. */ +{ + register unsigned int result; + register int c; + + /* + * I tried a zillion different hash functions and asked many other + * people for advice. Many people had their own favorite functions, + * all different, but no-one had much idea why they were good ones. + * I chose the one below (multiply by 9 and add new character) + * because of the following reasons: + * + * 1. Multiplying by 10 is perfect for keys that are decimal strings, + * and multiplying by 9 is just about as good. + * 2. Times-9 is (shift-left-3) plus (old). This means that each + * character's bits hang around in the low-order bits of the + * hash value for ever, plus they spread fairly rapidly up to + * the high-order bits to fill out the hash value. This seems + * works well both for decimal and non-decimal strings. + */ + + result = 0; + while (1) { + c = *string; + string++; + if (c == 0) { + break; + } + result += (result<<3) + c; + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * StringFind -- + * + * Given a hash table with string keys, and a string key, find + * the entry with a matching key. + * + * Results: + * The return value is a token for the matching entry in the + * hash table, or NULL if there was no matching entry. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static Tcl_HashEntry * +StringFind(tablePtr, key) + Tcl_HashTable *tablePtr; /* Table in which to lookup entry. */ + char *key; /* Key to use to find matching entry. */ +{ + register Tcl_HashEntry *hPtr; + register char *p1, *p2; + int index; + + index = HashString(key) & tablePtr->mask; + + /* + * Search all of the entries in the appropriate bucket. + */ + + for (hPtr = tablePtr->buckets[index]; hPtr != NULL; + hPtr = hPtr->nextPtr) { + for (p1 = key, p2 = hPtr->key.string; ; p1++, p2++) { + if (*p1 != *p2) { + break; + } + if (*p1 == '\0') { + return hPtr; + } + } + } + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * StringCreate -- + * + * Given a hash table with string keys, and a string key, find + * the entry with a matching key. If there is no matching entry, + * then create a new entry that does match. + * + * Results: + * The return value is a pointer to the matching entry. If this + * is a newly-created entry, then *newPtr will be set to a non-zero + * value; otherwise *newPtr will be set to 0. If this is a new + * entry the value stored in the entry will initially be 0. + * + * Side effects: + * A new entry may be added to the hash table. + * + *---------------------------------------------------------------------- + */ + +static Tcl_HashEntry * +StringCreate(tablePtr, key, newPtr) + Tcl_HashTable *tablePtr; /* Table in which to lookup entry. */ + char *key; /* Key to use to find or create matching + * entry. */ + int *newPtr; /* Store info here telling whether a new + * entry was created. */ +{ + register Tcl_HashEntry *hPtr; + register char *p1, *p2; + int index; + + index = HashString(key) & tablePtr->mask; + + /* + * Search all of the entries in this bucket. + */ + + for (hPtr = tablePtr->buckets[index]; hPtr != NULL; + hPtr = hPtr->nextPtr) { + for (p1 = key, p2 = hPtr->key.string; ; p1++, p2++) { + if (*p1 != *p2) { + break; + } + if (*p1 == '\0') { + *newPtr = 0; + return hPtr; + } + } + } + + /* + * Entry not found. Add a new one to the bucket. + */ + + *newPtr = 1; + hPtr = (Tcl_HashEntry *) ckalloc((unsigned) + (sizeof(Tcl_HashEntry) + strlen(key) - (sizeof(hPtr->key) -1))); + hPtr->tablePtr = tablePtr; + hPtr->bucketPtr = &(tablePtr->buckets[index]); + hPtr->nextPtr = *hPtr->bucketPtr; + hPtr->clientData = 0; + strcpy(hPtr->key.string, key); + *hPtr->bucketPtr = hPtr; + tablePtr->numEntries++; + + /* + * If the table has exceeded a decent size, rebuild it with many + * more buckets. + */ + + if (tablePtr->numEntries >= tablePtr->rebuildSize) { + RebuildTable(tablePtr); + } + return hPtr; +} + +/* + *---------------------------------------------------------------------- + * + * OneWordFind -- + * + * Given a hash table with one-word keys, and a one-word key, find + * the entry with a matching key. + * + * Results: + * The return value is a token for the matching entry in the + * hash table, or NULL if there was no matching entry. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static Tcl_HashEntry * +OneWordFind(tablePtr, key) + Tcl_HashTable *tablePtr; /* Table in which to lookup entry. */ + register char *key; /* Key to use to find matching entry. */ +{ + register Tcl_HashEntry *hPtr; + int index; + + index = RANDOM_INDEX(tablePtr, key); + + /* + * Search all of the entries in the appropriate bucket. + */ + + for (hPtr = tablePtr->buckets[index]; hPtr != NULL; + hPtr = hPtr->nextPtr) { + if (hPtr->key.oneWordValue == key) { + return hPtr; + } + } + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * OneWordCreate -- + * + * Given a hash table with one-word keys, and a one-word key, find + * the entry with a matching key. If there is no matching entry, + * then create a new entry that does match. + * + * Results: + * The return value is a pointer to the matching entry. If this + * is a newly-created entry, then *newPtr will be set to a non-zero + * value; otherwise *newPtr will be set to 0. If this is a new + * entry the value stored in the entry will initially be 0. + * + * Side effects: + * A new entry may be added to the hash table. + * + *---------------------------------------------------------------------- + */ + +static Tcl_HashEntry * +OneWordCreate(tablePtr, key, newPtr) + Tcl_HashTable *tablePtr; /* Table in which to lookup entry. */ + register char *key; /* Key to use to find or create matching + * entry. */ + int *newPtr; /* Store info here telling whether a new + * entry was created. */ +{ + register Tcl_HashEntry *hPtr; + int index; + + index = RANDOM_INDEX(tablePtr, key); + + /* + * Search all of the entries in this bucket. + */ + + for (hPtr = tablePtr->buckets[index]; hPtr != NULL; + hPtr = hPtr->nextPtr) { + if (hPtr->key.oneWordValue == key) { + *newPtr = 0; + return hPtr; + } + } + + /* + * Entry not found. Add a new one to the bucket. + */ + + *newPtr = 1; + hPtr = (Tcl_HashEntry *) ckalloc(sizeof(Tcl_HashEntry)); + hPtr->tablePtr = tablePtr; + hPtr->bucketPtr = &(tablePtr->buckets[index]); + hPtr->nextPtr = *hPtr->bucketPtr; + hPtr->clientData = 0; + hPtr->key.oneWordValue = key; + *hPtr->bucketPtr = hPtr; + tablePtr->numEntries++; + + /* + * If the table has exceeded a decent size, rebuild it with many + * more buckets. + */ + + if (tablePtr->numEntries >= tablePtr->rebuildSize) { + RebuildTable(tablePtr); + } + return hPtr; +} + +/* + *---------------------------------------------------------------------- + * + * ArrayFind -- + * + * Given a hash table with array-of-int keys, and a key, find + * the entry with a matching key. + * + * Results: + * The return value is a token for the matching entry in the + * hash table, or NULL if there was no matching entry. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static Tcl_HashEntry * +ArrayFind(tablePtr, key) + Tcl_HashTable *tablePtr; /* Table in which to lookup entry. */ + char *key; /* Key to use to find matching entry. */ +{ + register Tcl_HashEntry *hPtr; + int *arrayPtr = (int *) key; + register int *iPtr1, *iPtr2; + int index, count; + + for (index = 0, count = tablePtr->keyType, iPtr1 = arrayPtr; + count > 0; count--, iPtr1++) { + index += *iPtr1; + } + index = RANDOM_INDEX(tablePtr, index); + + /* + * Search all of the entries in the appropriate bucket. + */ + + for (hPtr = tablePtr->buckets[index]; hPtr != NULL; + hPtr = hPtr->nextPtr) { + for (iPtr1 = arrayPtr, iPtr2 = hPtr->key.words, + count = tablePtr->keyType; ; count--, iPtr1++, iPtr2++) { + if (count == 0) { + return hPtr; + } + if (*iPtr1 != *iPtr2) { + break; + } + } + } + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * ArrayCreate -- + * + * Given a hash table with one-word keys, and a one-word key, find + * the entry with a matching key. If there is no matching entry, + * then create a new entry that does match. + * + * Results: + * The return value is a pointer to the matching entry. If this + * is a newly-created entry, then *newPtr will be set to a non-zero + * value; otherwise *newPtr will be set to 0. If this is a new + * entry the value stored in the entry will initially be 0. + * + * Side effects: + * A new entry may be added to the hash table. + * + *---------------------------------------------------------------------- + */ + +static Tcl_HashEntry * +ArrayCreate(tablePtr, key, newPtr) + Tcl_HashTable *tablePtr; /* Table in which to lookup entry. */ + register char *key; /* Key to use to find or create matching + * entry. */ + int *newPtr; /* Store info here telling whether a new + * entry was created. */ +{ + register Tcl_HashEntry *hPtr; + int *arrayPtr = (int *) key; + register int *iPtr1, *iPtr2; + int index, count; + + for (index = 0, count = tablePtr->keyType, iPtr1 = arrayPtr; + count > 0; count--, iPtr1++) { + index += *iPtr1; + } + index = RANDOM_INDEX(tablePtr, index); + + /* + * Search all of the entries in the appropriate bucket. + */ + + for (hPtr = tablePtr->buckets[index]; hPtr != NULL; + hPtr = hPtr->nextPtr) { + for (iPtr1 = arrayPtr, iPtr2 = hPtr->key.words, + count = tablePtr->keyType; ; count--, iPtr1++, iPtr2++) { + if (count == 0) { + *newPtr = 0; + return hPtr; + } + if (*iPtr1 != *iPtr2) { + break; + } + } + } + + /* + * Entry not found. Add a new one to the bucket. + */ + + *newPtr = 1; + hPtr = (Tcl_HashEntry *) ckalloc((unsigned) (sizeof(Tcl_HashEntry) + + (tablePtr->keyType*sizeof(int)) - 4)); + hPtr->tablePtr = tablePtr; + hPtr->bucketPtr = &(tablePtr->buckets[index]); + hPtr->nextPtr = *hPtr->bucketPtr; + hPtr->clientData = 0; + for (iPtr1 = arrayPtr, iPtr2 = hPtr->key.words, count = tablePtr->keyType; + count > 0; count--, iPtr1++, iPtr2++) { + *iPtr2 = *iPtr1; + } + *hPtr->bucketPtr = hPtr; + tablePtr->numEntries++; + + /* + * If the table has exceeded a decent size, rebuild it with many + * more buckets. + */ + + if (tablePtr->numEntries >= tablePtr->rebuildSize) { + RebuildTable(tablePtr); + } + return hPtr; +} + +/* + *---------------------------------------------------------------------- + * + * BogusFind -- + * + * This procedure is invoked when an Tcl_FindHashEntry is called + * on a table that has been deleted. + * + * Results: + * If panic returns (which it shouldn't) this procedure returns + * NULL. + * + * Side effects: + * Generates a panic. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static Tcl_HashEntry * +BogusFind(tablePtr, key) + Tcl_HashTable *tablePtr; /* Table in which to lookup entry. */ + char *key; /* Key to use to find matching entry. */ +{ + panic("called Tcl_FindHashEntry on deleted table"); + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * BogusCreate -- + * + * This procedure is invoked when an Tcl_CreateHashEntry is called + * on a table that has been deleted. + * + * Results: + * If panic returns (which it shouldn't) this procedure returns + * NULL. + * + * Side effects: + * Generates a panic. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static Tcl_HashEntry * +BogusCreate(tablePtr, key, newPtr) + Tcl_HashTable *tablePtr; /* Table in which to lookup entry. */ + char *key; /* Key to use to find or create matching + * entry. */ + int *newPtr; /* Store info here telling whether a new + * entry was created. */ +{ + panic("called Tcl_CreateHashEntry on deleted table"); + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * RebuildTable -- + * + * This procedure is invoked when the ratio of entries to hash + * buckets becomes too large. It creates a new table with a + * larger bucket array and moves all of the entries into the + * new table. + * + * Results: + * None. + * + * Side effects: + * Memory gets reallocated and entries get re-hashed to new + * buckets. + * + *---------------------------------------------------------------------- + */ + +static void +RebuildTable(tablePtr) + register Tcl_HashTable *tablePtr; /* Table to enlarge. */ +{ + int oldSize, count, index; + Tcl_HashEntry **oldBuckets; + register Tcl_HashEntry **oldChainPtr, **newChainPtr; + register Tcl_HashEntry *hPtr; + + oldSize = tablePtr->numBuckets; + oldBuckets = tablePtr->buckets; + + /* + * Allocate and initialize the new bucket array, and set up + * hashing constants for new array size. + */ + + tablePtr->numBuckets *= 4; + tablePtr->buckets = (Tcl_HashEntry **) ckalloc((unsigned) + (tablePtr->numBuckets * sizeof(Tcl_HashEntry *))); + for (count = tablePtr->numBuckets, newChainPtr = tablePtr->buckets; + count > 0; count--, newChainPtr++) { + *newChainPtr = NULL; + } + tablePtr->rebuildSize *= 4; + tablePtr->downShift -= 2; + tablePtr->mask = (tablePtr->mask << 2) + 3; + + /* + * Rehash all of the existing entries into the new bucket array. + */ + + for (oldChainPtr = oldBuckets; oldSize > 0; oldSize--, oldChainPtr++) { + for (hPtr = *oldChainPtr; hPtr != NULL; hPtr = *oldChainPtr) { + *oldChainPtr = hPtr->nextPtr; + if (tablePtr->keyType == TCL_STRING_KEYS) { + index = HashString(hPtr->key.string) & tablePtr->mask; + } else if (tablePtr->keyType == TCL_ONE_WORD_KEYS) { + index = RANDOM_INDEX(tablePtr, hPtr->key.oneWordValue); + } else { + register int *iPtr; + int count; + + for (index = 0, count = tablePtr->keyType, + iPtr = hPtr->key.words; count > 0; count--, iPtr++) { + index += *iPtr; + } + index = RANDOM_INDEX(tablePtr, index); + } + hPtr->bucketPtr = &(tablePtr->buckets[index]); + hPtr->nextPtr = *hPtr->bucketPtr; + *hPtr->bucketPtr = hPtr; + } + } + + /* + * Free up the old bucket array, if it was dynamically allocated. + */ + + if (oldBuckets != tablePtr->staticBuckets) { + ckfree((char *) oldBuckets); + } +} diff --git a/vendor/x11iraf/obm/Tcl/tclHistory.c b/vendor/x11iraf/obm/Tcl/tclHistory.c new file mode 100644 index 00000000..5a4cadac --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/tclHistory.c @@ -0,0 +1,1109 @@ +/* + * tclHistory.c -- + * + * This module implements history as an optional addition to Tcl. + * It can be called to record commands ("events") before they are + * executed, and it provides a command that may be used to perform + * history substitutions. + * + * Copyright (c) 1990-1993 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. + */ + +#ifndef lint +static char rcsid[] = "$Header: /user6/ouster/tcl/RCS/tclHistory.c,v 1.30 93/10/13 13:05:38 ouster Exp $ SPRITE (Berkeley)"; +#endif /* not lint */ + +#include "tclInt.h" + +/* + * This history stuff is mostly straightforward, except for one thing + * that makes everything very complicated. Suppose that the following + * commands get executed: + * echo foo + * history redo + * It's important that the history event recorded for the second command + * be "echo foo", not "history redo". Otherwise, if another "history redo" + * command is typed, it will result in infinite recursions on the + * "history redo" command. Thus, the actual recorded history must be + * echo foo + * echo foo + * To do this, the history command revises recorded history as part of + * its execution. In the example above, when "history redo" starts + * execution, the current event is "history redo", but the history + * command arranges for the current event to be changed to "echo foo". + * + * There are three additional complications. The first is that history + * substitution may only be part of a command, as in the following + * command sequence: + * echo foo bar + * echo [history word 3] + * In this case, the second event should be recorded as "echo bar". Only + * part of the recorded event is to be modified. Fortunately, Tcl_Eval + * helps with this by recording (in the evalFirst and evalLast fields of + * the intepreter) the location of the command being executed, so the + * history module can replace exactly the range of bytes corresponding + * to the history substitution command. + * + * The second complication is that there are two ways to revise history: + * replace a command, and replace the result of a command. Consider the + * two examples below: + * format {result is %d} $num | format {result is %d} $num + * print [history redo] | print [history word 3] + * Recorded history for these two cases should be as follows: + * format {result is %d} $num | format {result is %d} $num + * print [format {result is %d} $num] | print $num + * In the left case, the history command was replaced with another command + * to be executed (the brackets were retained), but in the case on the + * right the result of executing the history command was replaced (i.e. + * brackets were replaced too). + * + * The third complication is that there could potentially be many + * history substitutions within a single command, as in: + * echo [history word 3] [history word 2] + * There could even be nested history substitutions, as in: + * history subs abc [history word 2] + * If history revisions were made immediately during each "history" command + * invocations, it would be very difficult to produce the correct cumulative + * effect from several substitutions in the same command. To get around + * this problem, the actual history revision isn't made during the execution + * of the "history" command. Information about the changes is just recorded, + * in xxx records, and the actual changes are made during the next call to + * Tcl_RecordHistory (when we know that execution of the previous command + * has finished). + */ + +/* + * Default space allocation for command strings: + */ + +#define INITIAL_CMD_SIZE 40 + +/* + * Forward declarations for procedures defined later in this file: + */ + +static void DoRevs _ANSI_ARGS_((Interp *iPtr)); +static HistoryEvent * GetEvent _ANSI_ARGS_((Interp *iPtr, char *string)); +static char * GetWords _ANSI_ARGS_((Interp *iPtr, char *command, + char *words)); +static void InitHistory _ANSI_ARGS_((Interp *iPtr)); +static void InsertRev _ANSI_ARGS_((Interp *iPtr, + HistoryRev *revPtr)); +static void MakeSpace _ANSI_ARGS_((HistoryEvent *hPtr, int size)); +static void RevCommand _ANSI_ARGS_((Interp *iPtr, char *string)); +static void RevResult _ANSI_ARGS_((Interp *iPtr, char *string)); +static int SubsAndEval _ANSI_ARGS_((Interp *iPtr, char *cmd, + char *old, char *new)); + +/* + *---------------------------------------------------------------------- + * + * InitHistory -- + * + * Initialize history-related state in an interpreter. + * + * Results: + * None. + * + * Side effects: + * History info is initialized in iPtr. + * + *---------------------------------------------------------------------- + */ + +static void +InitHistory(iPtr) + register Interp *iPtr; /* Interpreter to initialize. */ +{ + int i; + + if (iPtr->numEvents != 0) { + return; + } + iPtr->numEvents = 20; + iPtr->events = (HistoryEvent *) + ckalloc((unsigned) (iPtr->numEvents * sizeof(HistoryEvent))); + for (i = 0; i < iPtr->numEvents; i++) { + iPtr->events[i].command = (char *) ckalloc(INITIAL_CMD_SIZE); + *iPtr->events[i].command = 0; + iPtr->events[i].bytesAvl = INITIAL_CMD_SIZE; + } + iPtr->curEvent = 0; + iPtr->curEventNum = 0; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_RecordAndEval -- + * + * This procedure adds its command argument to the current list of + * recorded events and then executes the command by calling Tcl_Eval. + * + * Results: + * The return value is a standard Tcl return value, the result of + * executing cmd. + * + * Side effects: + * The command is recorded and executed. In addition, pending history + * revisions are carried out, and information is set up to enable + * Tcl_Eval to identify history command ranges. This procedure also + * initializes history information for the interpreter, if it hasn't + * already been initialized. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_RecordAndEval(interp, cmd, flags) + Tcl_Interp *interp; /* Token for interpreter in which command + * will be executed. */ + char *cmd; /* Command to record. */ + int flags; /* Additional flags to pass to Tcl_Eval. + * TCL_NO_EVAL means only record: don't + * execute command. */ +{ + register Interp *iPtr = (Interp *) interp; + register HistoryEvent *eventPtr; + int length, result; + + if (iPtr->numEvents == 0) { + InitHistory(iPtr); + } + DoRevs(iPtr); + + /* + * Don't record empty commands. + */ + + while (isspace(UCHAR(*cmd))) { + cmd++; + } + if (*cmd == '\0') { + Tcl_ResetResult(interp); + return TCL_OK; + } + + iPtr->curEventNum++; + iPtr->curEvent++; + if (iPtr->curEvent >= iPtr->numEvents) { + iPtr->curEvent = 0; + } + eventPtr = &iPtr->events[iPtr->curEvent]; + + /* + * Chop off trailing newlines before recording the command. + */ + + length = strlen(cmd); + while (cmd[length-1] == '\n') { + length--; + } + MakeSpace(eventPtr, length + 1); + strncpy(eventPtr->command, cmd, length); + eventPtr->command[length] = 0; + + /* + * Execute the command. Note: history revision isn't possible after + * a nested call to this procedure, because the event at the top of + * the history list no longer corresponds to what's going on when + * a nested call here returns. Thus, must leave history revision + * disabled when we return. + */ + + result = TCL_OK; + if (flags != TCL_NO_EVAL) { + iPtr->historyFirst = cmd; + iPtr->revDisables = 0; + iPtr->evalFlags = flags | TCL_RECORD_BOUNDS; + result = Tcl_Eval(interp, cmd); + } + iPtr->revDisables = 1; + return result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_HistoryCmd -- + * + * This procedure is invoked to process the "history" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_HistoryCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + register Interp *iPtr = (Interp *) interp; + register HistoryEvent *eventPtr; + int length; + char c; + + if (iPtr->numEvents == 0) { + InitHistory(iPtr); + } + + /* + * If no arguments, treat the same as "history info". + */ + + if (argc == 1) { + goto infoCmd; + } + + c = argv[1][0]; + length = strlen(argv[1]); + + if ((c == 'a') && (strncmp(argv[1], "add", length)) == 0) { + if ((argc != 3) && (argc != 4)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " add event ?exec?\"", (char *) NULL); + return TCL_ERROR; + } + if (argc == 4) { + if (strncmp(argv[3], "exec", strlen(argv[3])) != 0) { + Tcl_AppendResult(interp, "bad argument \"", argv[3], + "\": should be \"exec\"", (char *) NULL); + return TCL_ERROR; + } + return Tcl_RecordAndEval(interp, argv[2], 0); + } + return Tcl_RecordAndEval(interp, argv[2], TCL_NO_EVAL); + } else if ((c == 'c') && (strncmp(argv[1], "change", length)) == 0) { + if ((argc != 3) && (argc != 4)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " change newValue ?event?\"", (char *) NULL); + return TCL_ERROR; + } + if (argc == 3) { + eventPtr = &iPtr->events[iPtr->curEvent]; + iPtr->revDisables += 1; + while (iPtr->revPtr != NULL) { + HistoryRev *nextPtr; + + ckfree(iPtr->revPtr->newBytes); + nextPtr = iPtr->revPtr->nextPtr; + ckfree((char *) iPtr->revPtr); + iPtr->revPtr = nextPtr; + } + } else { + eventPtr = GetEvent(iPtr, argv[3]); + if (eventPtr == NULL) { + return TCL_ERROR; + } + } + MakeSpace(eventPtr, strlen(argv[2]) + 1); + strcpy(eventPtr->command, argv[2]); + return TCL_OK; + } else if ((c == 'e') && (strncmp(argv[1], "event", length)) == 0) { + if (argc > 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " event ?event?\"", (char *) NULL); + return TCL_ERROR; + } + eventPtr = GetEvent(iPtr, argc==2 ? "-1" : argv[2]); + if (eventPtr == NULL) { + return TCL_ERROR; + } + RevResult(iPtr, eventPtr->command); + Tcl_SetResult(interp, eventPtr->command, TCL_VOLATILE); + return TCL_OK; + } else if ((c == 'i') && (strncmp(argv[1], "info", length)) == 0) { + int count, indx, i; + char *newline; + + if ((argc != 2) && (argc != 3)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " info ?count?\"", (char *) NULL); + return TCL_ERROR; + } + infoCmd: + if (argc == 3) { + if (Tcl_GetInt(interp, argv[2], &count) != TCL_OK) { + return TCL_ERROR; + } + if (count > iPtr->numEvents) { + count = iPtr->numEvents; + } + } else { + count = iPtr->numEvents; + } + newline = ""; + for (i = 0, indx = iPtr->curEvent + 1 + iPtr->numEvents - count; + i < count; i++, indx++) { + char *cur, *next, savedChar; + char serial[20]; + + if (indx >= iPtr->numEvents) { + indx -= iPtr->numEvents; + } + cur = iPtr->events[indx].command; + if (*cur == '\0') { + continue; /* No command recorded here. */ + } + sprintf(serial, "%6d ", iPtr->curEventNum + 1 - (count - i)); + Tcl_AppendResult(interp, newline, serial, (char *) NULL); + newline = "\n"; + + /* + * Tricky formatting here: for multi-line commands, indent + * the continuation lines. + */ + + while (1) { + next = strchr(cur, '\n'); + if (next == NULL) { + break; + } + next++; + savedChar = *next; + *next = 0; + Tcl_AppendResult(interp, cur, "\t", (char *) NULL); + *next = savedChar; + cur = next; + } + Tcl_AppendResult(interp, cur, (char *) NULL); + } + return TCL_OK; + } else if ((c == 'k') && (strncmp(argv[1], "keep", length)) == 0) { + int count, i, src; + HistoryEvent *events; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " keep number\"", (char *) NULL); + return TCL_ERROR; + } + if (Tcl_GetInt(interp, argv[2], &count) != TCL_OK) { + return TCL_ERROR; + } + if ((count <= 0) || (count > 1000)) { + Tcl_AppendResult(interp, "illegal keep count \"", argv[2], + "\"", (char *) NULL); + return TCL_ERROR; + } + + /* + * Create a new history array and copy as much existing history + * as possible from the old array. + */ + + events = (HistoryEvent *) + ckalloc((unsigned) (count * sizeof(HistoryEvent))); + if (count < iPtr->numEvents) { + src = iPtr->curEvent + 1 - count; + if (src < 0) { + src += iPtr->numEvents; + } + } else { + src = iPtr->curEvent + 1; + } + for (i = 0; i < count; i++, src++) { + if (src >= iPtr->numEvents) { + src = 0; + } + if (i < iPtr->numEvents) { + events[i] = iPtr->events[src]; + iPtr->events[src].command = NULL; + } else { + events[i].command = (char *) ckalloc(INITIAL_CMD_SIZE); + events[i].command[0] = 0; + events[i].bytesAvl = INITIAL_CMD_SIZE; + } + } + + /* + * Throw away everything left in the old history array, and + * substitute the new one for the old one. + */ + + for (i = 0; i < iPtr->numEvents; i++) { + if (iPtr->events[i].command != NULL) { + ckfree(iPtr->events[i].command); + } + } + ckfree((char *) iPtr->events); + iPtr->events = events; + if (count < iPtr->numEvents) { + iPtr->curEvent = count-1; + } else { + iPtr->curEvent = iPtr->numEvents-1; + } + iPtr->numEvents = count; + return TCL_OK; + } else if ((c == 'n') && (strncmp(argv[1], "nextid", length)) == 0) { + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " nextid\"", (char *) NULL); + return TCL_ERROR; + } + sprintf(iPtr->result, "%d", iPtr->curEventNum+1); + return TCL_OK; + } else if ((c == 'r') && (strncmp(argv[1], "redo", length)) == 0) { + if (argc > 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " redo ?event?\"", (char *) NULL); + return TCL_ERROR; + } + eventPtr = GetEvent(iPtr, argc==2 ? "-1" : argv[2]); + if (eventPtr == NULL) { + return TCL_ERROR; + } + RevCommand(iPtr, eventPtr->command); + return Tcl_Eval(interp, eventPtr->command); + } else if ((c == 's') && (strncmp(argv[1], "substitute", length)) == 0) { + if ((argc > 5) || (argc < 4)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " substitute old new ?event?\"", (char *) NULL); + return TCL_ERROR; + } + eventPtr = GetEvent(iPtr, argc==4 ? "-1" : argv[4]); + if (eventPtr == NULL) { + return TCL_ERROR; + } + return SubsAndEval(iPtr, eventPtr->command, argv[2], argv[3]); + } else if ((c == 'w') && (strncmp(argv[1], "words", length)) == 0) { + char *words; + + if ((argc != 3) && (argc != 4)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " words num-num/pat ?event?\"", (char *) NULL); + return TCL_ERROR; + } + eventPtr = GetEvent(iPtr, argc==3 ? "-1" : argv[3]); + if (eventPtr == NULL) { + return TCL_ERROR; + } + words = GetWords(iPtr, eventPtr->command, argv[2]); + if (words == NULL) { + return TCL_ERROR; + } + RevResult(iPtr, words); + iPtr->result = words; + iPtr->freeProc = (Tcl_FreeProc *) free; + return TCL_OK; + } + + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": must be add, change, event, info, keep, nextid, ", + "redo, substitute, or words", (char *) NULL); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * MakeSpace -- + * + * Given a history event, make sure it has enough space for + * a string of a given length (enlarge the string area if + * necessary). + * + * Results: + * None. + * + * Side effects: + * More memory may get allocated. + * + *---------------------------------------------------------------------- + */ + +static void +MakeSpace(hPtr, size) + HistoryEvent *hPtr; + int size; /* # of bytes needed in hPtr. */ +{ + if (hPtr->bytesAvl < size) { + ckfree(hPtr->command); + hPtr->command = (char *) ckalloc((unsigned) size); + hPtr->bytesAvl = size; + } +} + +/* + *---------------------------------------------------------------------- + * + * InsertRev -- + * + * Add a new revision to the list of those pending for iPtr. + * Do it in a way that keeps the revision list sorted in + * increasing order of firstIndex. Also, eliminate revisions + * that are subsets of other revisions. + * + * Results: + * None. + * + * Side effects: + * RevPtr is added to iPtr's revision list. + * + *---------------------------------------------------------------------- + */ + +static void +InsertRev(iPtr, revPtr) + Interp *iPtr; /* Interpreter to use. */ + register HistoryRev *revPtr; /* Revision to add to iPtr's list. */ +{ + register HistoryRev *curPtr; + register HistoryRev *prevPtr; + + for (curPtr = iPtr->revPtr, prevPtr = NULL; curPtr != NULL; + prevPtr = curPtr, curPtr = curPtr->nextPtr) { + /* + * If this revision includes the new one (or vice versa) then + * just eliminate the one that is a subset of the other. + */ + + if ((revPtr->firstIndex <= curPtr->firstIndex) + && (revPtr->lastIndex >= curPtr->firstIndex)) { + curPtr->firstIndex = revPtr->firstIndex; + curPtr->lastIndex = revPtr->lastIndex; + curPtr->newSize = revPtr->newSize; + ckfree(curPtr->newBytes); + curPtr->newBytes = revPtr->newBytes; + ckfree((char *) revPtr); + return; + } + if ((revPtr->firstIndex >= curPtr->firstIndex) + && (revPtr->lastIndex <= curPtr->lastIndex)) { + ckfree(revPtr->newBytes); + ckfree((char *) revPtr); + return; + } + + if (revPtr->firstIndex < curPtr->firstIndex) { + break; + } + } + + /* + * Insert revPtr just after prevPtr. + */ + + if (prevPtr == NULL) { + revPtr->nextPtr = iPtr->revPtr; + iPtr->revPtr = revPtr; + } else { + revPtr->nextPtr = prevPtr->nextPtr; + prevPtr->nextPtr = revPtr; + } +} + +/* + *---------------------------------------------------------------------- + * + * RevCommand -- + * + * This procedure is invoked by the "history" command to record + * a command revision. See the comments at the beginning of the + * file for more information about revisions. + * + * Results: + * None. + * + * Side effects: + * Revision information is recorded. + * + *---------------------------------------------------------------------- + */ + +static void +RevCommand(iPtr, string) + register Interp *iPtr; /* Interpreter in which to perform the + * substitution. */ + char *string; /* String to substitute. */ +{ + register HistoryRev *revPtr; + + if ((iPtr->evalFirst == NULL) || (iPtr->revDisables > 0)) { + return; + } + revPtr = (HistoryRev *) ckalloc(sizeof(HistoryRev)); + revPtr->firstIndex = iPtr->evalFirst - iPtr->historyFirst; + revPtr->lastIndex = iPtr->evalLast - iPtr->historyFirst; + revPtr->newSize = strlen(string); + revPtr->newBytes = (char *) ckalloc((unsigned) (revPtr->newSize+1)); + strcpy(revPtr->newBytes, string); + InsertRev(iPtr, revPtr); +} + +/* + *---------------------------------------------------------------------- + * + * RevResult -- + * + * This procedure is invoked by the "history" command to record + * a result revision. See the comments at the beginning of the + * file for more information about revisions. + * + * Results: + * None. + * + * Side effects: + * Revision information is recorded. + * + *---------------------------------------------------------------------- + */ + +static void +RevResult(iPtr, string) + register Interp *iPtr; /* Interpreter in which to perform the + * substitution. */ + char *string; /* String to substitute. */ +{ + register HistoryRev *revPtr; + char *evalFirst, *evalLast; + char *argv[2]; + + if ((iPtr->evalFirst == NULL) || (iPtr->revDisables > 0)) { + return; + } + + /* + * Expand the replacement range to include the brackets that surround + * the command. If there aren't any brackets (i.e. this command was + * invoked at top-level) then don't do any revision. Also, if there + * are several commands in brackets, of which this is just one, + * then don't do any revision. + */ + + evalFirst = iPtr->evalFirst; + evalLast = iPtr->evalLast + 1; + while (1) { + if (evalFirst == iPtr->historyFirst) { + return; + } + evalFirst--; + if (*evalFirst == '[') { + break; + } + if (!isspace(UCHAR(*evalFirst))) { + return; + } + } + if (*evalLast != ']') { + return; + } + + revPtr = (HistoryRev *) ckalloc(sizeof(HistoryRev)); + revPtr->firstIndex = evalFirst - iPtr->historyFirst; + revPtr->lastIndex = evalLast - iPtr->historyFirst; + argv[0] = string; + revPtr->newBytes = Tcl_Merge(1, argv); + revPtr->newSize = strlen(revPtr->newBytes); + InsertRev(iPtr, revPtr); +} + +/* + *---------------------------------------------------------------------- + * + * DoRevs -- + * + * This procedure is called to apply the history revisions that + * have been recorded in iPtr. + * + * Results: + * None. + * + * Side effects: + * The most recent entry in the history for iPtr may be modified. + * + *---------------------------------------------------------------------- + */ + +static void +DoRevs(iPtr) + register Interp *iPtr; /* Interpreter whose history is to + * be modified. */ +{ + register HistoryRev *revPtr; + register HistoryEvent *eventPtr; + char *newCommand, *p; + unsigned int size; + int bytesSeen, count; + + if (iPtr->revPtr == NULL) { + return; + } + + /* + * The revision is done in two passes. The first pass computes the + * amount of space needed for the revised event, and the second pass + * pieces together the new event and frees up the revisions. + */ + + eventPtr = &iPtr->events[iPtr->curEvent]; + size = strlen(eventPtr->command) + 1; + for (revPtr = iPtr->revPtr; revPtr != NULL; revPtr = revPtr->nextPtr) { + size -= revPtr->lastIndex + 1 - revPtr->firstIndex; + size += revPtr->newSize; + } + + newCommand = (char *) ckalloc(size); + p = newCommand; + bytesSeen = 0; + for (revPtr = iPtr->revPtr; revPtr != NULL; ) { + HistoryRev *nextPtr = revPtr->nextPtr; + + count = revPtr->firstIndex - bytesSeen; + if (count > 0) { + strncpy(p, eventPtr->command + bytesSeen, count); + p += count; + } + strncpy(p, revPtr->newBytes, revPtr->newSize); + p += revPtr->newSize; + bytesSeen = revPtr->lastIndex+1; + ckfree(revPtr->newBytes); + ckfree((char *) revPtr); + revPtr = nextPtr; + } + if (&p[strlen(&eventPtr->command[bytesSeen]) + 1] > + &newCommand[size]) { + printf("Assertion failed!\n"); + } + strcpy(p, eventPtr->command + bytesSeen); + + /* + * Replace the command in the event. + */ + + ckfree(eventPtr->command); + eventPtr->command = newCommand; + eventPtr->bytesAvl = size; + iPtr->revPtr = NULL; +} + +/* + *---------------------------------------------------------------------- + * + * GetEvent -- + * + * Given a textual description of an event (see the manual page + * for legal values) find the corresponding event and return its + * command string. + * + * Results: + * The return value is a pointer to the event named by "string". + * If no such event exists, then NULL is returned and an error + * message is left in iPtr. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static HistoryEvent * +GetEvent(iPtr, string) + register Interp *iPtr; /* Interpreter in which to look. */ + char *string; /* Description of event. */ +{ + int eventNum, index; + register HistoryEvent *eventPtr; + int length; + + /* + * First check for a numeric specification of an event. + */ + + if (isdigit(UCHAR(*string)) || (*string == '-')) { + if (Tcl_GetInt((Tcl_Interp *) iPtr, string, &eventNum) != TCL_OK) { + return NULL; + } + if (eventNum < 0) { + eventNum += iPtr->curEventNum; + } + if (eventNum > iPtr->curEventNum) { + Tcl_AppendResult((Tcl_Interp *) iPtr, "event \"", string, + "\" hasn't occurred yet", (char *) NULL); + return NULL; + } + if ((eventNum <= iPtr->curEventNum-iPtr->numEvents) + || (eventNum <= 0)) { + Tcl_AppendResult((Tcl_Interp *) iPtr, "event \"", string, + "\" is too far in the past", (char *) NULL); + return NULL; + } + index = iPtr->curEvent + (eventNum - iPtr->curEventNum); + if (index < 0) { + index += iPtr->numEvents; + } + return &iPtr->events[index]; + } + + /* + * Next, check for an event that contains the string as a prefix or + * that matches the string in the sense of Tcl_StringMatch. + */ + + length = strlen(string); + for (index = iPtr->curEvent - 1; ; index--) { + if (index < 0) { + index += iPtr->numEvents; + } + if (index == iPtr->curEvent) { + break; + } + eventPtr = &iPtr->events[index]; + if ((strncmp(eventPtr->command, string, length) == 0) + || Tcl_StringMatch(eventPtr->command, string)) { + return eventPtr; + } + } + + Tcl_AppendResult((Tcl_Interp *) iPtr, "no event matches \"", string, + "\"", (char *) NULL); + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * SubsAndEval -- + * + * Generate a new command by making a textual substitution in + * the "cmd" argument. Then execute the new command. + * + * Results: + * The return value is a standard Tcl error. + * + * Side effects: + * History gets revised if the substitution is occurring on + * a recorded command line. Also, the re-executed command + * may produce side-effects. + * + *---------------------------------------------------------------------- + */ + +static int +SubsAndEval(iPtr, cmd, old, new) + register Interp *iPtr; /* Interpreter in which to execute + * new command. */ + char *cmd; /* Command in which to substitute. */ + char *old; /* String to search for in command. */ + char *new; /* Replacement string for "old". */ +{ + char *src, *dst, *newCmd; + int count, oldLength, newLength, length, result; + + /* + * Figure out how much space it will take to hold the + * substituted command (and complain if the old string + * doesn't appear in the original command). + */ + + oldLength = strlen(old); + newLength = strlen(new); + src = cmd; + count = 0; + while (1) { + src = strstr(src, old); + if (src == NULL) { + break; + } + src += oldLength; + count++; + } + if (count == 0) { + Tcl_AppendResult((Tcl_Interp *) iPtr, "\"", old, + "\" doesn't appear in event", (char *) NULL); + return TCL_ERROR; + } + length = strlen(cmd) + count*(newLength - oldLength); + + /* + * Generate a substituted command. + */ + + newCmd = (char *) ckalloc((unsigned) (length + 1)); + dst = newCmd; + while (1) { + src = strstr(cmd, old); + if (src == NULL) { + strcpy(dst, cmd); + break; + } + strncpy(dst, cmd, src-cmd); + dst += src-cmd; + strcpy(dst, new); + dst += newLength; + cmd = src + oldLength; + } + + RevCommand(iPtr, newCmd); + result = Tcl_Eval((Tcl_Interp *) iPtr, newCmd); + ckfree(newCmd); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * GetWords -- + * + * Given a command string, return one or more words from the + * command string. + * + * Results: + * The return value is a pointer to a dynamically-allocated + * string containing the words of command specified by "words". + * If the word specifier has improper syntax then an error + * message is placed in iPtr->result and NULL is returned. + * + * Side effects: + * Memory is allocated. It is the caller's responsibilty to + * free the returned string.. + * + *---------------------------------------------------------------------- + */ + +static char * +GetWords(iPtr, command, words) + register Interp *iPtr; /* Tcl interpreter in which to place + * an error message if needed. */ + char *command; /* Command string. */ + char *words; /* Description of which words to extract + * from the command. Either num[-num] or + * a pattern. */ +{ + char *result; + char *start, *end, *dst; + register char *next; + int first; /* First word desired. -1 means last word + * only. */ + int last; /* Last word desired. -1 means use everything + * up to the end. */ + int index; /* Index of current word. */ + char *pattern; + + /* + * Figure out whether we're looking for a numerical range or for + * a pattern. + */ + + pattern = NULL; + first = 0; + last = -1; + if (*words == '$') { + if (words[1] != '\0') { + goto error; + } + first = -1; + } else if (isdigit(UCHAR(*words))) { + first = strtoul(words, &start, 0); + if (*start == 0) { + last = first; + } else if (*start == '-') { + start++; + if (*start == '$') { + start++; + } else if (isdigit(UCHAR(*start))) { + last = strtoul(start, &start, 0); + } else { + goto error; + } + if (*start != 0) { + goto error; + } + } + if ((first > last) && (last != -1)) { + goto error; + } + } else { + pattern = words; + } + + /* + * Scan through the words one at a time, copying those that are + * relevant into the result string. Allocate a result area large + * enough to hold all the words if necessary. + */ + + result = (char *) ckalloc((unsigned) (strlen(command) + 1)); + dst = result; + for (next = command; isspace(UCHAR(*next)); next++) { + /* Empty loop body: just find start of first word. */ + } + for (index = 0; *next != 0; index++) { + start = next; + end = TclWordEnd(next, 0, (int *) NULL); + if (*end != 0) { + end++; + for (next = end; isspace(UCHAR(*next)); next++) { + /* Empty loop body: just find start of next word. */ + } + } + if ((first > index) || ((first == -1) && (*next != 0))) { + continue; + } + if ((last != -1) && (last < index)) { + continue; + } + if (pattern != NULL) { + int match; + char savedChar = *end; + + *end = 0; + match = Tcl_StringMatch(start, pattern); + *end = savedChar; + if (!match) { + continue; + } + } + if (dst != result) { + *dst = ' '; + dst++; + } + strncpy(dst, start, (end-start)); + dst += end-start; + } + *dst = 0; + + /* + * Check for an out-of-range argument index. + */ + + if ((last >= index) || (first >= index)) { + ckfree(result); + Tcl_AppendResult((Tcl_Interp *) iPtr, "word selector \"", words, + "\" specified non-existent words", (char *) NULL); + return NULL; + } + return result; + + error: + Tcl_AppendResult((Tcl_Interp *) iPtr, "bad word selector \"", words, + "\": should be num-num or pattern", (char *) NULL); + return NULL; +} diff --git a/vendor/x11iraf/obm/Tcl/tclInt.h b/vendor/x11iraf/obm/Tcl/tclInt.h new file mode 100644 index 00000000..1f59a065 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/tclInt.h @@ -0,0 +1,947 @@ +/* + * tclInt.h -- + * + * Declarations of things used internally by the Tcl interpreter. + * + * Copyright (c) 1987-1993 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. + * + * $Header: /user6/ouster/tcl/RCS/tclInt.h,v 1.94 93/10/15 16:36:51 ouster Exp $ SPRITE (Berkeley) + */ + +#ifndef _TCLINT +#define _TCLINT + +/* + * Common include files needed by most of the Tcl source files are + * included here, so that system-dependent personalizations for the + * include files only have to be made in once place. This results + * in a few extra includes, but greater modularity. The order of + * the three groups of #includes is important. For example, stdio.h + * is needed by tcl.h, and the _ANSI_ARGS_ declaration in tcl.h is + * needed by stdlib.h in some configurations. + */ + +#include <stdio.h> + +#ifndef _TCL +#include "tcl.h" +#endif +#ifndef _REGEXP +#include "tclRegexp.h" +#endif + +#include <ctype.h> +#ifdef NO_LIMITS_H +# include "compat/limits.h" +#else +# include <limits.h> +#endif +#ifdef NO_STDLIB_H +# include "compat/stdlib.h" +#else +# include <stdlib.h> +#endif +#ifdef NO_STRING_H +#include "compat/string.h" +#else +#include <string.h> +#endif + +/* +*/ +#if defined(__DARWIN__) || defined(USE_STDARG) +#include <stdarg.h> +#else +#include <varargs.h> +#endif + +/* Workaround for our old varargs handling on LinuxPPC systems. +#if defined(linux) && defined(__powerpc__) +#undef va_start +#undef va_alist +#undef va_dcl + +#define va_start(AP) __va_start_common (AP, 1) +#define va_alist __va_1st_arg +#define va_dcl register int va_alist; ... +#endif +*/ + + +/* + * At present (12/91) not all stdlib.h implementations declare strtod. + * The declaration below is here to ensure that it's declared, so that + * the compiler won't take the default approach of assuming it returns + * an int. There's no ANSI prototype for it because there would end + * up being too many conflicts with slightly-different prototypes. + */ + +extern double strtod(); + +/* + *---------------------------------------------------------------- + * Data structures related to variables. These are used primarily + * in tclVar.c + *---------------------------------------------------------------- + */ + +/* + * The following structure defines a variable trace, which is used to + * invoke a specific C procedure whenever certain operations are performed + * on a variable. + */ + +typedef struct VarTrace { + Tcl_VarTraceProc *traceProc;/* Procedure to call when operations given + * by flags are performed on variable. */ + ClientData clientData; /* Argument to pass to proc. */ + int flags; /* What events the trace procedure is + * interested in: OR-ed combination of + * TCL_TRACE_READS, TCL_TRACE_WRITES, and + * TCL_TRACE_UNSETS. */ + struct VarTrace *nextPtr; /* Next in list of traces associated with + * a particular variable. */ +} VarTrace; + +/* + * When a variable trace is active (i.e. its associated procedure is + * executing), one of the following structures is linked into a list + * associated with the variable's interpreter. The information in + * the structure is needed in order for Tcl to behave reasonably + * if traces are deleted while traces are active. + */ + +typedef struct ActiveVarTrace { + struct Var *varPtr; /* Variable that's being traced. */ + struct ActiveVarTrace *nextPtr; + /* Next in list of all active variable + * traces for the interpreter, or NULL + * if no more. */ + VarTrace *nextTracePtr; /* Next trace to check after current + * trace procedure returns; if this + * trace gets deleted, must update pointer + * to avoid using free'd memory. */ +} ActiveVarTrace; + +/* + * The following structure describes an enumerative search in progress on + * an array variable; this are invoked with options to the "array" + * command. + */ + +typedef struct ArraySearch { + int id; /* Integer id used to distinguish among + * multiple concurrent searches for the + * same array. */ + struct Var *varPtr; /* Pointer to array variable that's being + * searched. */ + Tcl_HashSearch search; /* Info kept by the hash module about + * progress through the array. */ + Tcl_HashEntry *nextEntry; /* Non-null means this is the next element + * to be enumerated (it's leftover from + * the Tcl_FirstHashEntry call or from + * an "array anymore" command). NULL + * means must call Tcl_NextHashEntry + * to get value to return. */ + struct ArraySearch *nextPtr;/* Next in list of all active searches + * for this variable, or NULL if this is + * the last one. */ +} ArraySearch; + +/* + * The structure below defines a variable, which associates a string name + * with a string value. Pointers to these structures are kept as the + * values of hash table entries, and the name of each variable is stored + * in the hash entry. + */ + +typedef struct Var { + int valueLength; /* Holds the number of non-null bytes + * actually occupied by the variable's + * current value in value.string (extra + * space is sometimes left for expansion). + * For array and global variables this is + * meaningless. */ + int valueSpace; /* Total number of bytes of space allocated + * at value.string. 0 means there is no + * space allocated. */ + union { + char *string; /* String value of variable, used for scalar + * variables and array elements. Malloc-ed. */ + Tcl_HashTable *tablePtr;/* For array variables, this points to + * information about the hash table used + * to implement the associative array. + * Points to malloc-ed data. */ + struct Var *upvarPtr; /* If this is a global variable being + * referred to in a procedure, or a variable + * created by "upvar", this field points to + * the record for the higher-level variable. */ + } value; + Tcl_HashEntry *hPtr; /* Hash table entry that refers to this + * variable, or NULL if the variable has + * been detached from its hash table (e.g. + * an array is deleted, but some of its + * elements are still referred to in upvars). */ + int refCount; /* Counts number of active uses of this + * variable, not including its main hash + * table entry: 1 for each additional variable + * whose upVarPtr points here, 1 for each + * nested trace active on variable. This + * record can't be deleted until refCount + * becomes 0. */ + VarTrace *tracePtr; /* First in list of all traces set for this + * variable. */ + ArraySearch *searchPtr; /* First in list of all searches active + * for this variable, or NULL if none. */ + int flags; /* Miscellaneous bits of information about + * variable. See below for definitions. */ +} Var; + +/* + * Flag bits for variables: + * + * VAR_ARRAY - 1 means this is an array variable rather + * than a scalar variable. + * VAR_UPVAR - 1 means this variable just contains a + * pointer to another variable that has the + * real value. Variables like this come + * about through the "upvar" and "global" + * commands. + * VAR_UNDEFINED - 1 means that the variable is currently + * undefined. Undefined variables usually + * go away completely, but if an undefined + * variable has a trace on it, or if it is + * a global variable being used by a procedure, + * then it stays around even when undefined. + * VAR_TRACE_ACTIVE - 1 means that trace processing is currently + * underway for a read or write access, so + * new read or write accesses should not cause + * trace procedures to be called and the + * variable can't be deleted. + */ + +#define VAR_ARRAY 1 +#define VAR_UPVAR 2 +#define VAR_UNDEFINED 4 +#define VAR_TRACE_ACTIVE 0x10 + +/* + *---------------------------------------------------------------- + * Data structures related to procedures. These are used primarily + * in tclProc.c + *---------------------------------------------------------------- + */ + +/* + * The structure below defines an argument to a procedure, which + * consists of a name and an (optional) default value. + */ + +typedef struct Arg { + struct Arg *nextPtr; /* Next argument for this procedure, + * or NULL if this is the last argument. */ + char *defValue; /* Pointer to arg's default value, or NULL + * if no default value. */ + char name[4]; /* Name of argument starts here. The name + * is followed by space for the default, + * if there is one. The actual size of this + * field will be as large as necessary to + * hold both name and default value. THIS + * MUST BE THE LAST FIELD IN THE STRUCTURE!! */ +} Arg; + +/* + * The structure below defines a command procedure, which consists of + * a collection of Tcl commands plus information about arguments and + * variables. + */ + +typedef struct Proc { + struct Interp *iPtr; /* Interpreter for which this command + * is defined. */ + int refCount; /* Reference count: 1 if still present + * in command table plus 1 for each call + * to the procedure that is currently + * active. This structure can be freed + * when refCount becomes zero. */ + char *command; /* Command that constitutes the body of + * the procedure (dynamically allocated). */ + Arg *argPtr; /* Pointer to first of procedure's formal + * arguments, or NULL if none. */ +} Proc; + +/* + * The structure below defines a command trace. This is used to allow Tcl + * clients to find out whenever a command is about to be executed. + */ + +typedef struct Trace { + int level; /* Only trace commands at nesting level + * less than or equal to this. */ + Tcl_CmdTraceProc *proc; /* Procedure to call to trace command. */ + ClientData clientData; /* Arbitrary value to pass to proc. */ + struct Trace *nextPtr; /* Next in list of traces for this interp. */ +} Trace; + +/* + * The stucture below defines a deletion callback, which is + * a procedure to invoke just before an interpreter is deleted. + */ + +typedef struct DeleteCallback { + Tcl_InterpDeleteProc *proc; /* Procedure to call. */ + ClientData clientData; /* Value to pass to procedure. */ + struct DeleteCallback *nextPtr; + /* Next in list of callbacks for this + * interpreter (or NULL for end of list). */ +} DeleteCallback; + +/* + * The structure below defines a frame, which is a procedure invocation. + * These structures exist only while procedures are being executed, and + * provide a sort of call stack. + */ + +typedef struct CallFrame { + Tcl_HashTable varTable; /* Hash table containing all of procedure's + * local variables. */ + int level; /* Level of this procedure, for "uplevel" + * purposes (i.e. corresponds to nesting of + * callerVarPtr's, not callerPtr's). 1 means + * outer-most procedure, 0 means top-level. */ + int argc; /* This and argv below describe name and + * arguments for this procedure invocation. */ + char **argv; /* Array of arguments. */ + struct CallFrame *callerPtr; + /* Value of interp->framePtr when this + * procedure was invoked (i.e. next in + * stack of all active procedures). */ + struct CallFrame *callerVarPtr; + /* Value of interp->varFramePtr when this + * procedure was invoked (i.e. determines + * variable scoping within caller; same + * as callerPtr unless an "uplevel" command + * or something equivalent was active in + * the caller). */ +} CallFrame; + +/* + * The structure below defines one history event (a previously-executed + * command that can be re-executed in whole or in part). + */ + +typedef struct { + char *command; /* String containing previously-executed + * command. */ + int bytesAvl; /* Total # of bytes available at *event (not + * all are necessarily in use now). */ +} HistoryEvent; + +/* + *---------------------------------------------------------------- + * Data structures related to history. These are used primarily + * in tclHistory.c + *---------------------------------------------------------------- + */ + +/* + * The structure below defines a pending revision to the most recent + * history event. Changes are linked together into a list and applied + * during the next call to Tcl_RecordHistory. See the comments at the + * beginning of tclHistory.c for information on revisions. + */ + +typedef struct HistoryRev { + int firstIndex; /* Index of the first byte to replace in + * current history event. */ + int lastIndex; /* Index of last byte to replace in + * current history event. */ + int newSize; /* Number of bytes in newBytes. */ + char *newBytes; /* Replacement for the range given by + * firstIndex and lastIndex. */ + struct HistoryRev *nextPtr; /* Next in chain of revisions to apply, or + * NULL for end of list. */ +} HistoryRev; + +/* + *---------------------------------------------------------------- + * Data structures related to files. These are used primarily in + * tclUnixUtil.c and tclUnixAZ.c. + *---------------------------------------------------------------- + */ + +/* + * The data structure below defines an open file (or connection to + * a process pipeline) as returned by the "open" command. + */ + +typedef struct OpenFile { + FILE *f; /* Stdio file to use for reading and/or + * writing. */ + FILE *f2; /* Normally NULL. In the special case of + * a command pipeline with pipes for both + * input and output, this is a stdio file + * to use for writing to the pipeline. */ + int permissions; /* OR-ed combination of TCL_FILE_READABLE + * and TCL_FILE_WRITABLE. */ + int numPids; /* If this is a connection to a process + * pipeline, gives number of processes + * in pidPtr array below; otherwise it + * is 0. */ + int *pidPtr; /* Pointer to malloc-ed array of child + * process ids (numPids of them), or NULL + * if this isn't a connection to a process + * pipeline. */ + int errorId; /* File id of file that receives error + * output from pipeline. -1 means not + * used (i.e. this is a normal file). */ +} OpenFile; + +/* + *---------------------------------------------------------------- + * Data structures related to expressions. These are used only in + * tclExpr.c. + *---------------------------------------------------------------- + */ + +/* + * The data structure below defines a math function (e.g. sin or hypot) + * for use in Tcl expressions. + */ + +#define MAX_MATH_ARGS 5 +typedef struct MathFunc { + int numArgs; /* Number of arguments for function. */ + Tcl_ValueType argTypes[MAX_MATH_ARGS]; + /* Acceptable types for each argument. */ + Tcl_MathProc *proc; /* Procedure that implements this function. */ + ClientData clientData; /* Additional argument to pass to the function + * when invoking it. */ +} MathFunc; + +/* + *---------------------------------------------------------------- + * This structure defines an interpreter, which is a collection of + * commands plus other state information related to interpreting + * commands, such as variable storage. Primary responsibility for + * this data structure is in tclBasic.c, but almost every Tcl + * source file uses something in here. + *---------------------------------------------------------------- + */ + +typedef struct Command { + Tcl_CmdProc *proc; /* Procedure to process command. */ + ClientData clientData; /* Arbitrary value to pass to proc. */ + Tcl_CmdDeleteProc *deleteProc; + /* Procedure to invoke when deleting + * command. */ + ClientData deleteData; /* Arbitrary value to pass to deleteProc + * (usually the same as clientData). */ +} Command; + +#define CMD_SIZE(nameLength) ((unsigned) sizeof(Command) + nameLength - 3) + +typedef struct Interp { + + /* + * Note: the first three fields must match exactly the fields in + * a Tcl_Interp struct (see tcl.h). If you change one, be sure to + * change the other. + */ + + char *result; /* Points to result returned by last + * command. */ + Tcl_FreeProc *freeProc; /* Zero means result is statically allocated. + * If non-zero, gives address of procedure + * to invoke to free the result. Must be + * freed by Tcl_Eval before executing next + * command. */ + int errorLine; /* When TCL_ERROR is returned, this gives + * the line number within the command where + * the error occurred (1 means first line). */ + Tcl_HashTable commandTable; /* Contains all of the commands currently + * registered in this interpreter. Indexed + * by strings; values have type (Command *). */ + Tcl_HashTable mathFuncTable;/* Contains all of the math functions currently + * defined for the interpreter. Indexed by + * strings (function names); values have + * type (MathFunc *). */ + + /* + * Information related to procedures and variables. See tclProc.c + * and tclvar.c for usage. + */ + + Tcl_HashTable globalTable; /* Contains all global variables for + * interpreter. */ + int numLevels; /* Keeps track of how many nested calls to + * Tcl_Eval are in progress for this + * interpreter. It's used to delay deletion + * of the table until all Tcl_Eval invocations + * are completed. */ + int maxNestingDepth; /* If numLevels exceeds this value then Tcl + * assumes that infinite recursion has + * occurred and it generates an error. */ + CallFrame *framePtr; /* Points to top-most in stack of all nested + * procedure invocations. NULL means there + * are no active procedures. */ + CallFrame *varFramePtr; /* Points to the call frame whose variables + * are currently in use (same as framePtr + * unless an "uplevel" command is being + * executed). NULL means no procedure is + * active or "uplevel 0" is being exec'ed. */ + ActiveVarTrace *activeTracePtr; + /* First in list of active traces for interp, + * or NULL if no active traces. */ + int returnCode; /* Completion code to return if current + * procedure exits with a TCL_RETURN code. */ + char *errorInfo; /* Value to store in errorInfo if returnCode + * is TCL_ERROR. Malloc'ed, may be NULL */ + char *errorCode; /* Value to store in errorCode if returnCode + * is TCL_ERROR. Malloc'ed, may be NULL */ + + /* + * Information related to history: + */ + + int numEvents; /* Number of previously-executed commands + * to retain. */ + HistoryEvent *events; /* Array containing numEvents entries + * (dynamically allocated). */ + int curEvent; /* Index into events of place where current + * (or most recent) command is recorded. */ + int curEventNum; /* Event number associated with the slot + * given by curEvent. */ + HistoryRev *revPtr; /* First in list of pending revisions. */ + char *historyFirst; /* First char. of current command executed + * from history module or NULL if none. */ + int revDisables; /* 0 means history revision OK; > 0 gives + * a count of number of times revision has + * been disabled. */ + char *evalFirst; /* If TCL_RECORD_BOUNDS flag set, Tcl_Eval + * sets this field to point to the first + * char. of text from which the current + * command came. Otherwise Tcl_Eval sets + * this to NULL. */ + char *evalLast; /* Similar to evalFirst, except points to + * last character of current command. */ + + /* + * Information used by Tcl_AppendResult to keep track of partial + * results. See Tcl_AppendResult code for details. + */ + + char *appendResult; /* Storage space for results generated + * by Tcl_AppendResult. Malloc-ed. NULL + * means not yet allocated. */ + int appendAvl; /* Total amount of space available at + * partialResult. */ + int appendUsed; /* Number of non-null bytes currently + * stored at partialResult. */ + + /* + * A cache of compiled regular expressions. See TclCompileRegexp + * in tclUtil.c for details. + */ + +#define NUM_REGEXPS 5 + char *patterns[NUM_REGEXPS];/* Strings corresponding to compiled + * regular expression patterns. NULL + * means that this slot isn't used. + * Malloc-ed. */ + int patLengths[NUM_REGEXPS];/* Number of non-null characters in + * corresponding entry in patterns. + * -1 means entry isn't used. */ + regexp *regexps[NUM_REGEXPS]; + /* Compiled forms of above strings. Also + * malloc-ed, or NULL if not in use yet. */ + + /* + * Information used by Tcl_PrintDouble: + */ + + char pdFormat[10]; /* Format string used by Tcl_PrintDouble. */ + int pdPrec; /* Current precision (used to restore the + * the tcl_precision variable after a bogus + * value has been put into it). */ + + /* + * Miscellaneous information: + */ + + int cmdCount; /* Total number of times a command procedure + * has been called for this interpreter. */ + int noEval; /* Non-zero means no commands should actually + * be executed: just parse only. Used in + * expressions when the result is already + * determined. */ + int evalFlags; /* Flags to control next call to Tcl_Eval. + * Normally zero, but may be set before + * calling Tcl_Eval to an OR'ed combination + * of TCL_BRACKET_TERM and TCL_RECORD_BOUNDS. */ + char *termPtr; /* Character just after the last one in + * a command. Set by Tcl_Eval before + * returning. */ + char *scriptFile; /* NULL means there is no nested source + * command active; otherwise this points to + * the name of the file being sourced (it's + * not malloc-ed: it points to an argument + * to Tcl_EvalFile. */ + int flags; /* Various flag bits. See below. */ + Trace *tracePtr; /* List of traces for this interpreter. */ + DeleteCallback *deleteCallbackPtr; + /* First in list of callbacks to invoke when + * interpreter is deleted. */ + char resultSpace[TCL_RESULT_SIZE+1]; + /* Static space for storing small results. */ +} Interp; + +/* + * Flag bits for Interp structures: + * + * DELETED: Non-zero means the interpreter has been deleted: + * don't process any more commands for it, and destroy + * the structure as soon as all nested invocations of + * Tcl_Eval are done. + * ERR_IN_PROGRESS: Non-zero means an error unwind is already in progress. + * Zero means a command proc has been invoked since last + * error occured. + * ERR_ALREADY_LOGGED: Non-zero means information has already been logged + * in $errorInfo for the current Tcl_Eval instance, + * so Tcl_Eval needn't log it (used to implement the + * "error message log" command). + * ERROR_CODE_SET: Non-zero means that Tcl_SetErrorCode has been + * called to record information for the current + * error. Zero means Tcl_Eval must clear the + * errorCode variable if an error is returned. + * EXPR_INITIALIZED: 1 means initialization specific to expressions has + * been carried out. + */ + +#define DELETED 1 +#define ERR_IN_PROGRESS 2 +#define ERR_ALREADY_LOGGED 4 +#define ERROR_CODE_SET 8 +#define EXPR_INITIALIZED 0x10 + +/* + * Default value for the pdPrec and pdFormat fields of interpreters: + */ + +#define DEFAULT_PD_PREC 6 +#define DEFAULT_PD_FORMAT "%g" + +/* + *---------------------------------------------------------------- + * Data structures related to command parsing. These are used in + * tclParse.c and its clients. + *---------------------------------------------------------------- + */ + +/* + * The following data structure is used by various parsing procedures + * to hold information about where to store the results of parsing + * (e.g. the substituted contents of a quoted argument, or the result + * of a nested command). At any given time, the space available + * for output is fixed, but a procedure may be called to expand the + * space available if the current space runs out. + */ + +typedef struct ParseValue { + char *buffer; /* Address of first character in + * output buffer. */ + char *next; /* Place to store next character in + * output buffer. */ + char *end; /* Address of the last usable character + * in the buffer. */ + void (*expandProc) _ANSI_ARGS_((struct ParseValue *pvPtr, int needed)); + /* Procedure to call when space runs out; + * it will make more space. */ + ClientData clientData; /* Arbitrary information for use of + * expandProc. */ +} ParseValue; + +/* + * A table used to classify input characters to assist in parsing + * Tcl commands. The table should be indexed with a signed character + * using the CHAR_TYPE macro. The character may have a negative + * value. + */ + +extern char tclTypeTable[]; +#define CHAR_TYPE(c) (tclTypeTable+128)[c] + +/* + * Possible values returned by CHAR_TYPE: + * + * TCL_NORMAL - All characters that don't have special significance + * to the Tcl language. + * TCL_SPACE - Character is space, tab, or return. + * TCL_COMMAND_END - Character is newline or null or semicolon or + * close-bracket. + * TCL_QUOTE - Character is a double-quote. + * TCL_OPEN_BRACKET - Character is a "[". + * TCL_OPEN_BRACE - Character is a "{". + * TCL_CLOSE_BRACE - Character is a "}". + * TCL_BACKSLASH - Character is a "\". + * TCL_DOLLAR - Character is a "$". + */ + +#define TCL_NORMAL 0 +#define TCL_SPACE 1 +#define TCL_COMMAND_END 2 +#define TCL_QUOTE 3 +#define TCL_OPEN_BRACKET 4 +#define TCL_OPEN_BRACE 5 +#define TCL_CLOSE_BRACE 6 +#define TCL_BACKSLASH 7 +#define TCL_DOLLAR 8 + +/* + * Additional flags passed to Tcl_Eval. See tcl.h for other flags to + * Tcl_Eval; these ones are only used internally by Tcl. + * + * TCL_RECORD_BOUNDS Tells Tcl_Eval to record information in the + * evalFirst and evalLast fields for each command + * executed directly from the string (top-level + * commands and those from command substitution). + */ + +#define TCL_RECORD_BOUNDS 0x100 + +/* + * Maximum number of levels of nesting permitted in Tcl commands (used + * to catch infinite recursion). + */ + +#define MAX_NESTING_DEPTH 1000 + +/* + * The macro below is used to modify a "char" value (e.g. by casting + * it to an unsigned character) so that it can be used safely with + * macros such as isspace. + */ + +#define UCHAR(c) ((unsigned char) (c)) + +/* + * Given a size or address, the macro below "aligns" it to the machine's + * memory unit size (e.g. an 8-byte boundary) so that anything can be + * placed at the aligned address without fear of an alignment error. + */ + +#define TCL_ALIGN(x) ((x + 7) & ~7) + +/* + * Variables shared among Tcl modules but not used by the outside + * world: + */ + +extern int tclNumFiles; +extern OpenFile ** tclOpenFiles; +extern char * tclRegexpError; + +/* + *---------------------------------------------------------------- + * Procedures shared among Tcl modules but not used by the outside + * world: + *---------------------------------------------------------------- + */ + +extern void panic(); +extern regexp * TclCompileRegexp _ANSI_ARGS_((Tcl_Interp *interp, + char *string)); +extern void TclCopyAndCollapse _ANSI_ARGS_((int count, char *src, + char *dst)); +extern void TclDeleteVars _ANSI_ARGS_((Interp *iPtr, + Tcl_HashTable *tablePtr)); +extern void TclExpandParseValue _ANSI_ARGS_((ParseValue *pvPtr, + int needed)); +extern int TclFindElement _ANSI_ARGS_((Tcl_Interp *interp, + char *list, char **elementPtr, char **nextPtr, + int *sizePtr, int *bracePtr)); +extern Proc * TclFindProc _ANSI_ARGS_((Interp *iPtr, + char *procName)); +extern int TclGetFrame _ANSI_ARGS_((Tcl_Interp *interp, + char *string, CallFrame **framePtrPtr)); +extern int TclGetListIndex _ANSI_ARGS_((Tcl_Interp *interp, + char *string, int *indexPtr)); +extern Proc * TclIsProc _ANSI_ARGS_((Command *cmdPtr)); +extern int TclParseBraces _ANSI_ARGS_((Tcl_Interp *interp, + char *string, char **termPtr, ParseValue *pvPtr)); +extern int TclParseNestedCmd _ANSI_ARGS_((Tcl_Interp *interp, + char *string, int flags, char **termPtr, + ParseValue *pvPtr)); +extern int TclParseQuotes _ANSI_ARGS_((Tcl_Interp *interp, + char *string, int termChar, int flags, + char **termPtr, ParseValue *pvPtr)); +extern int TclParseWords _ANSI_ARGS_((Tcl_Interp *interp, + char *string, int flags, int maxWords, + char **termPtr, int *argcPtr, char **argv, + ParseValue *pvPtr)); +extern char * TclPrecTraceProc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, char *name1, char *name2, + int flags)); +extern void TclSetupEnv _ANSI_ARGS_((Tcl_Interp *interp)); +extern char * TclWordEnd _ANSI_ARGS_((char *start, int nested, + int *semiPtr)); + +/* + *---------------------------------------------------------------- + * Command procedures in the generic core: + *---------------------------------------------------------------- + */ + +extern int Tcl_AppendCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +extern int Tcl_ArrayCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +extern int Tcl_BreakCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +extern int Tcl_CaseCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +extern int Tcl_CatchCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +extern int Tcl_ConcatCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +extern int Tcl_ContinueCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +extern int Tcl_ErrorCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +extern int Tcl_EvalCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +extern int Tcl_ExprCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +extern int Tcl_ForCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +extern int Tcl_ForeachCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +extern int Tcl_FormatCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +extern int Tcl_GlobalCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +extern int Tcl_HistoryCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +extern int Tcl_IfCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +extern int Tcl_IncrCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +extern int Tcl_InfoCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +extern int Tcl_JoinCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +extern int Tcl_LappendCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +extern int Tcl_LindexCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +extern int Tcl_LinsertCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +extern int Tcl_LlengthCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +extern int Tcl_ListCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +extern int Tcl_LrangeCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +extern int Tcl_LreplaceCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +extern int Tcl_LsearchCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +extern int Tcl_LsortCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +extern int Tcl_ProcCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +extern int Tcl_RegexpCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +extern int Tcl_RegsubCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +extern int Tcl_RenameCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +extern int Tcl_ReturnCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +extern int Tcl_ScanCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +extern int Tcl_SetCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +extern int Tcl_SplitCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +extern int Tcl_StringCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +extern int Tcl_SwitchCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +extern int Tcl_TraceCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +extern int Tcl_UnsetCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +extern int Tcl_UplevelCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +extern int Tcl_UpvarCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +extern int Tcl_WhileCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +extern int Tcl_Cmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +extern int Tcl_Cmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); + +/* + *---------------------------------------------------------------- + * Command procedures in the UNIX core: + *---------------------------------------------------------------- + */ + +extern int Tcl_CdCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +extern int Tcl_CloseCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +extern int Tcl_EofCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +extern int Tcl_ExecCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +extern int Tcl_ExitCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +extern int Tcl_FileCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +extern int Tcl_FlushCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +extern int Tcl_GetsCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +extern int Tcl_GlobCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +extern int Tcl_OpenCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +extern int Tcl_PutsCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +extern int Tcl_PidCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +extern int Tcl_PwdCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +extern int Tcl_ReadCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +extern int Tcl_SeekCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +extern int Tcl_SourceCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +extern int Tcl_TellCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +extern int Tcl_TimeCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); + +#endif /* _TCLINT */ diff --git a/vendor/x11iraf/obm/Tcl/tclLink.c b/vendor/x11iraf/obm/Tcl/tclLink.c new file mode 100644 index 00000000..887d9766 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/tclLink.c @@ -0,0 +1,361 @@ +/* + * tclLink.c -- + * + * This file implements linked variables (a C variable that is + * tied to a Tcl variable). The idea of linked variables was + * first suggested by Andreas Stocke and this implementation is + * based heavily on a prototype implementation provided by + * him. + * + * Copyright (c) 1993 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. + */ + +#ifndef lint +static char rcsid[] = "$Header: /user6/ouster/tcl/RCS/tclLink.c,v 1.4 93/07/29 15:24:05 ouster Exp $ SPRITE (Berkeley)"; +#endif /* not lint */ + +#include "tclInt.h" + +/* + * For each linked variable there is a data structure of the following + * type, which describes the link and is the clientData for the trace + * set on the Tcl variable. + */ + +typedef struct Link { + Tcl_Interp *interp; /* Interpreter containing Tcl variable. */ + char *addr; /* Location of C variable. */ + int type; /* Type of link (TCL_LINK_INT, etc.). */ + int writable; /* Zero means Tcl variable is read-only. */ + union { + int i; + double d; + } lastValue; /* Last known value of C variable; used to + * avoid string conversions. */ +} Link; + +/* + * Forward references to procedures defined later in this file: + */ + +static char * LinkTraceProc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, char *name1, char *name2, + int flags)); +static char * StringValue _ANSI_ARGS_((Link *linkPtr, + char *buffer)); + +/* + *---------------------------------------------------------------------- + * + * Tcl_LinkVar -- + * + * Link a C variable to a Tcl variable so that changes to either + * one causes the other to change. + * + * Results: + * The return value is TCL_OK if everything went well or TCL_ERROR + * if an error occurred (interp->result is also set after errors). + * + * Side effects: + * The value at *addr is linked to the Tcl variable "varName", + * using "type" to convert between string values for Tcl and + * binary values for *addr. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_LinkVar(interp, varName, addr, type) + Tcl_Interp *interp; /* Interpreter in which varName exists. */ + char *varName; /* Name of a global variable in interp. */ + char *addr; /* Address of a C variable to be linked + * to varName. */ + int type; /* Type of C variable: TCL_LINK_INT, etc. + * Also may have TCL_LINK_READ_ONLY + * OR'ed in. */ +{ + Link *linkPtr; + char buffer[TCL_DOUBLE_SPACE]; + int code; + + linkPtr = (Link *) ckalloc(sizeof(Link)); + linkPtr->interp = interp; + linkPtr->addr = addr; + linkPtr->type = type & ~TCL_LINK_READ_ONLY; + linkPtr->writable = (type & TCL_LINK_READ_ONLY) == 0; + if (Tcl_SetVar(interp, varName, StringValue(linkPtr, buffer), + TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) { + ckfree((char *) linkPtr); + return TCL_ERROR; + } + code = Tcl_TraceVar(interp, varName, TCL_GLOBAL_ONLY|TCL_TRACE_READS + |TCL_TRACE_WRITES|TCL_TRACE_UNSETS, LinkTraceProc, + (ClientData) linkPtr); + if (code != TCL_OK) { + ckfree((char *) linkPtr); + } + return code; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_UnlinkVar -- + * + * Destroy the link between a Tcl variable and a C variable. + * + * Results: + * None. + * + * Side effects: + * If "varName" was previously linked to a C variable, the link + * is broken to make the variable independent. If there was no + * previous link for "varName" then nothing happens. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_UnlinkVar(interp, varName) + Tcl_Interp *interp; /* Interpreter containing variable to unlink. */ + char *varName; /* Global variable in interp to unlink. */ +{ + Link *linkPtr; + + linkPtr = (Link *) Tcl_VarTraceInfo(interp, varName, TCL_GLOBAL_ONLY, + LinkTraceProc, (ClientData) NULL); + if (linkPtr == NULL) { + return; + } + Tcl_UntraceVar(interp, varName, + TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + LinkTraceProc, (ClientData) linkPtr); + ckfree((char *) linkPtr); +} + +/* + *---------------------------------------------------------------------- + * + * LinkTraceProc -- + * + * This procedure is invoked when a linked Tcl variable is read, + * written, or unset from Tcl. It's responsible for keeping the + * C variable in sync with the Tcl variable. + * + * Results: + * If all goes well, NULL is returned; otherwise an error message + * is returned. + * + * Side effects: + * The C variable may be updated to make it consistent with the + * Tcl variable, or the Tcl variable may be overwritten to reject + * a modification. + * + *---------------------------------------------------------------------- + */ + +static char * +LinkTraceProc(clientData, interp, name1, name2, flags) + ClientData clientData; /* Contains information about the link. */ + Tcl_Interp *interp; /* Interpreter containing Tcl variable. */ + char *name1; /* First part of variable name. */ + char *name2; /* Second part of variable name. */ + int flags; /* Miscellaneous additional information. */ +{ + Link *linkPtr = (Link *) clientData; + int changed; + char buffer[TCL_DOUBLE_SPACE]; + char *value, **pp; + Tcl_DString savedResult; + + /* + * If the variable is being unset, then just re-create it (with a + * trace) unless the whole interpreter is going away. + */ + + if (flags & TCL_TRACE_UNSETS) { + if (flags & TCL_INTERP_DESTROYED) { + ckfree((char *) linkPtr); + } + if (flags & TCL_TRACE_DESTROYED) { + Tcl_SetVar2(interp, name1, name2, + StringValue(linkPtr, buffer), TCL_GLOBAL_ONLY); + Tcl_TraceVar2(interp, name1, name2, TCL_GLOBAL_ONLY + |TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + LinkTraceProc, (ClientData) linkPtr); + } + return NULL; + } + + /* + * For read accesses, update the Tcl variable if the C variable + * has changed since the last time we updated the Tcl variable. + */ + + if (flags & TCL_TRACE_READS) { + switch (linkPtr->type) { + case TCL_LINK_INT: + case TCL_LINK_BOOLEAN: + changed = *(int *)(linkPtr->addr) != linkPtr->lastValue.i; + break; + case TCL_LINK_DOUBLE: + changed = *(double *)(linkPtr->addr) != linkPtr->lastValue.d; + break; + case TCL_LINK_STRING: + changed = 1; + break; + default: + return "internal error: bad linked variable type"; + } + if (changed) { + Tcl_SetVar2(interp, name1, name2, StringValue(linkPtr, buffer), + TCL_GLOBAL_ONLY); + } + return NULL; + } + + /* + * For writes, first make sure that the variable is writable. Then + * convert the Tcl value to C if possible. If the variable isn't + * writable or can't be converted, then restore the varaible's old + * value and return an error. Another tricky thing: we have to save + * and restore the interpreter's result, since the variable access + * could occur when the result has been partially set. + */ + + if (!linkPtr->writable) { + Tcl_SetVar2(interp, name1, name2, StringValue(linkPtr, buffer), + TCL_GLOBAL_ONLY); + return "linked variable is read-only"; + } + value = Tcl_GetVar2(interp, name1, name2, TCL_GLOBAL_ONLY); + if (value == NULL) { + /* + * This shouldn't ever happen. + */ + return "internal error: linked variable couldn't be read"; + } + Tcl_DStringInit(&savedResult); + Tcl_DStringAppend(&savedResult, interp->result, -1); + Tcl_ResetResult(interp); + switch (linkPtr->type) { + case TCL_LINK_INT: + if (Tcl_GetInt(interp, value, &linkPtr->lastValue.i) != TCL_OK) { + Tcl_DStringResult(interp, &savedResult); + Tcl_SetVar2(interp, name1, name2, StringValue(linkPtr, buffer), + TCL_GLOBAL_ONLY); + return "variable must have integer value"; + } + *(int *)(linkPtr->addr) = linkPtr->lastValue.i; + break; + case TCL_LINK_DOUBLE: + if (Tcl_GetDouble(interp, value, &linkPtr->lastValue.d) + != TCL_OK) { + Tcl_DStringResult(interp, &savedResult); + Tcl_SetVar2(interp, name1, name2, StringValue(linkPtr, buffer), + TCL_GLOBAL_ONLY); + return "variable must have real value"; + } + *(double *)(linkPtr->addr) = linkPtr->lastValue.d; + break; + case TCL_LINK_BOOLEAN: + if (Tcl_GetBoolean(interp, value, &linkPtr->lastValue.i) + != TCL_OK) { + Tcl_DStringResult(interp, &savedResult); + Tcl_SetVar2(interp, name1, name2, StringValue(linkPtr, buffer), + TCL_GLOBAL_ONLY); + return "variable must have boolean value"; + } + *(int *)(linkPtr->addr) = linkPtr->lastValue.i; + break; + case TCL_LINK_STRING: + pp = (char **)(linkPtr->addr); + if (*pp != NULL) { + ckfree(*pp); + } + *pp = ckalloc((unsigned) (strlen(value) + 1)); + strcpy(*pp, value); + break; + default: + return "internal error: bad linked variable type"; + } + Tcl_DStringResult(interp, &savedResult); + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * StringValue -- + * + * Converts the value of a C variable to a string for use in a + * Tcl variable to which it is linked. + * + * Results: + * The return value is a pointer + to a string that represents + * the value of the C variable given by linkPtr. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static char * +StringValue(linkPtr, buffer) + Link *linkPtr; /* Structure describing linked variable. */ + char *buffer; /* Small buffer to use for converting + * values. Must have TCL_DOUBLE_SPACE + * bytes or more. */ +{ + char *p; + + switch (linkPtr->type) { + case TCL_LINK_INT: + linkPtr->lastValue.i = *(int *)(linkPtr->addr); + sprintf(buffer, "%d", linkPtr->lastValue.i); + return buffer; + case TCL_LINK_DOUBLE: + linkPtr->lastValue.d = *(double *)(linkPtr->addr); + Tcl_PrintDouble(linkPtr->interp, linkPtr->lastValue.d, buffer); + return buffer; + case TCL_LINK_BOOLEAN: + linkPtr->lastValue.i = *(int *)(linkPtr->addr); + if (linkPtr->lastValue.i != 0) { + return "1"; + } + return "0"; + case TCL_LINK_STRING: + p = *(char **)(linkPtr->addr); + if (p == NULL) { + return "NULL"; + } + return p; + } + + /* + * This code only gets executed if the link type is unknown + * (shouldn't ever happen). + */ + + return "??"; +} diff --git a/vendor/x11iraf/obm/Tcl/tclMain.c b/vendor/x11iraf/obm/Tcl/tclMain.c new file mode 100644 index 00000000..f080dcd2 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/tclMain.c @@ -0,0 +1,296 @@ +/* + * main.c -- + * + * Main program for Tcl shells and other Tcl-based applications. + * + * Copyright (c) 1988-1993 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. + */ + +#ifndef lint +static char rcsid[] = "$Header: /user6/ouster/tcl/RCS/tclMain.c,v 1.12 93/11/11 09:35:10 ouster Exp $ SPRITE (Berkeley)"; +#endif + +#include <stdio.h> +#include <tcl.h> +#include <errno.h> + +/* + * Declarations for various library procedures and variables (don't want + * to include tclUnix.h here, because people might copy this file out of + * the Tcl source directory to make their own modified versions). + */ + +extern int errno; +extern void exit _ANSI_ARGS_((int status)); +extern int isatty _ANSI_ARGS_((int fd)); +extern char * strcpy _ANSI_ARGS_((char *dst, CONST char *src)); + +static Tcl_Interp *interp; /* Interpreter for application. */ +static Tcl_DString command; /* Used to buffer incomplete commands being + * read from stdin. */ +char *tcl_RcFileName = NULL; /* Name of a user-specific startup script + * to source if the application is being run + * interactively (e.g. "~/.tclshrc"). Set + * by Tcl_AppInit. NULL means don't source + * anything ever. */ +#ifdef TCL_MEM_DEBUG +static char dumpFile[100]; /* Records where to dump memory allocation + * information. */ +static int quitFlag = 0; /* 1 means the "checkmem" command was + * invoked, so the application should quit + * and dump memory allocation information. */ +#endif + +/* + * Forward references for procedures defined later in this file: + */ + +static int CheckmemCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char *argv[])); + +/* + *---------------------------------------------------------------------- + * + * main -- + * + * This is the main program for a Tcl-based shell that reads + * Tcl commands from standard input. + * + * Results: + * None. + * + * Side effects: + * Can be almost arbitrary, depending on what the Tcl commands do. + * + *---------------------------------------------------------------------- + */ + +int +main(argc, argv) + int argc; /* Number of arguments. */ + char **argv; /* Array of argument strings. */ +{ + char buffer[1000], *cmd, *args, *fileName; + int code, gotPartial, tty; + int exitCode = 0; + + interp = Tcl_CreateInterp(); +#ifdef TCL_MEM_DEBUG + Tcl_InitMemory(interp); + Tcl_CreateCommand(interp, "checkmem", CheckmemCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); +#endif + + /* + * Make command-line arguments available in the Tcl variables "argc" + * and "argv". If the first argument doesn't start with a "-" then + * strip it off and use it as the name of a script file to process. + */ + + fileName = NULL; + if ((argc > 1) && (argv[1][0] != '-')) { + fileName = argv[1]; + argc--; + argv++; + } + args = Tcl_Merge(argc-1, argv+1); + Tcl_SetVar(interp, "argv", args, TCL_GLOBAL_ONLY); + ckfree(args); + sprintf(buffer, "%d", argc-1); + Tcl_SetVar(interp, "argc", buffer, TCL_GLOBAL_ONLY); + Tcl_SetVar(interp, "argv0", (fileName != NULL) ? fileName : argv[0], + TCL_GLOBAL_ONLY); + + /* + * Set the "tcl_interactive" variable. + */ + + tty = isatty(0); + Tcl_SetVar(interp, "tcl_interactive", + ((fileName == NULL) && tty) ? "1" : "0", TCL_GLOBAL_ONLY); + + /* + * Invoke application-specific initialization. + */ + + if (Tcl_AppInit(interp) != TCL_OK) { + fprintf(stderr, "Tcl_AppInit failed: %s\n", interp->result); + } + + /* + * If a script file was specified then just source that file + * and quit. + */ + + if (fileName != NULL) { + code = Tcl_EvalFile(interp, fileName); + if (code != TCL_OK) { + fprintf(stderr, "%s\n", interp->result); + exitCode = 1; + } + goto done; + } + + /* + * We're running interactively. Source a user-specific startup + * file if Tcl_AppInit specified one and if the file exists. + */ + + if (tcl_RcFileName != NULL) { + Tcl_DString buffer; + char *fullName; + FILE *f; + + fullName = Tcl_TildeSubst(interp, tcl_RcFileName, &buffer); + if (fullName == NULL) { + fprintf(stderr, "%s\n", interp->result); + } else { + f = fopen(fullName, "r"); + if (f != NULL) { + code = Tcl_EvalFile(interp, fullName); + if (code != TCL_OK) { + fprintf(stderr, "%s\n", interp->result); + } + fclose(f); + } + } + Tcl_DStringFree(&buffer); + } + + /* + * Process commands from stdin until there's an end-of-file. + */ + + gotPartial = 0; + Tcl_DStringInit(&command); + while (1) { + clearerr(stdin); + if (tty) { + char *promptCmd; + + promptCmd = Tcl_GetVar(interp, + gotPartial ? "tcl_prompt2" : "tcl_prompt1", TCL_GLOBAL_ONLY); + if (promptCmd == NULL) { + defaultPrompt: + if (!gotPartial) { + fputs("% ", stdout); + } + } else { + code = Tcl_Eval(interp, promptCmd); + if (code != TCL_OK) { + fprintf(stderr, "%s\n", interp->result); + Tcl_AddErrorInfo(interp, + "\n (script that generates prompt)"); + goto defaultPrompt; + } + } + fflush(stdout); + } + if (fgets(buffer, 1000, stdin) == NULL) { + if (ferror(stdin)) { + if (errno == EINTR) { + if (tcl_AsyncReady) { + (void) Tcl_AsyncInvoke((Tcl_Interp *) NULL, 0); + } + clearerr(stdin); + } else { + goto done; + } + } else { + if (!gotPartial) { + goto done; + } + } + buffer[0] = 0; + } + cmd = Tcl_DStringAppend(&command, buffer, -1); + if ((buffer[0] != 0) && !Tcl_CommandComplete(cmd)) { + gotPartial = 1; + continue; + } + + gotPartial = 0; + code = Tcl_RecordAndEval(interp, cmd, 0); + Tcl_DStringFree(&command); + if (code != TCL_OK) { + fprintf(stderr, "%s\n", interp->result); + } else if (tty && (*interp->result != 0)) { + printf("%s\n", interp->result); + } +#ifdef TCL_MEM_DEBUG + if (quitFlag) { + Tcl_DeleteInterp(interp); + Tcl_DumpActiveMemory(dumpFile); + exit(0); + } +#endif + } + + /* + * Rather than calling exit, invoke the "exit" command so that + * users can replace "exit" with some other command to do additional + * cleanup on exit. The Tcl_Eval call should never return. + */ + + done: + sprintf(buffer, "exit %d", exitCode); + Tcl_Eval(interp, buffer); + return 1; +} + +/* + *---------------------------------------------------------------------- + * + * CheckmemCmd -- + * + * This is the command procedure for the "checkmem" command, which + * causes the application to exit after printing information about + * memory usage to the file passed to this command as its first + * argument. + * + * Results: + * Returns a standard Tcl completion code. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ +#ifdef TCL_MEM_DEBUG + + /* ARGSUSED */ +static int +CheckmemCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Interpreter for evaluation. */ + int argc; /* Number of arguments. */ + char *argv[]; /* String values of arguments. */ +{ + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " fileName\"", (char *) NULL); + return TCL_ERROR; + } + strcpy(dumpFile, argv[1]); + quitFlag = 1; + return TCL_OK; +} +#endif diff --git a/vendor/x11iraf/obm/Tcl/tclMtherr.c b/vendor/x11iraf/obm/Tcl/tclMtherr.c new file mode 100644 index 00000000..81c14ac5 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/tclMtherr.c @@ -0,0 +1,89 @@ +/* + * tclMatherr.c -- + * + * This function provides a default implementation of the + * "matherr" function, for SYS-V systems where it's needed. + * + * Copyright (c) 1993 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. + */ + +#ifndef lint +static char rcsid[] = "$Header: /user6/ouster/tcl/RCS/tclMtherr.c,v 1.7 93/10/31 16:19:31 ouster Exp $ SPRITE (Berkeley)"; +#endif /* not lint */ + +#include "tclInt.h" +#include <math.h> + +#ifndef TCL_GENERIC_ONLY +#include "tclUnix.h" +#else +#define NO_ERRNO_H +#endif + +#ifdef NO_ERRNO_H +extern int errno; /* Use errno from tclExpr.c. */ +#define EDOM 33 +#define ERANGE 34 +#endif + +/* + * The following variable is secretly shared with Tcl so we can + * tell if expression evaluation is in progress. If not, matherr + * just emulates the default behavior, which includes printing + * a message. + */ + +extern int tcl_MathInProgress; + + +/* + *---------------------------------------------------------------------- + * + * matherr -- + * + * This procedure is invoked on Sys-V systems when certain + * errors occur in mathematical functions. Type "man matherr" + * for more information on how this function works. + * + * Results: + * Returns 1 to indicate that we've handled the error + * locally. + * + * Side effects: + * Sets errno based on what's in xPtr. + * + *---------------------------------------------------------------------- + */ + +int +matherr(xPtr) + struct exception *xPtr; /* Describes error that occurred. */ +{ + if (!tcl_MathInProgress) { + return 0; + } + if ((xPtr->type == DOMAIN) || (xPtr->type == SING)) { + errno = EDOM; + } else { + errno = ERANGE; + } + return 1; +} diff --git a/vendor/x11iraf/obm/Tcl/tclParse.c b/vendor/x11iraf/obm/Tcl/tclParse.c new file mode 100644 index 00000000..433e0544 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/tclParse.c @@ -0,0 +1,1284 @@ +/* + * tclParse.c -- + * + * This file contains a collection of procedures that are used + * to parse Tcl commands or parts of commands (like quoted + * strings or nested sub-commands). + * + * Copyright (c) 1987-1993 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. + */ + +#ifndef lint +static char rcsid[] = "$Header: /user6/ouster/tcl/RCS/tclParse.c,v 1.37 93/10/14 15:14:06 ouster Exp $ SPRITE (Berkeley)"; +#endif + +#include "tclInt.h" + +/* Slackware/RedHat4.2 compatibility hack. */ +#if defined(linux) && defined(isalnum) +#undef isalnum +#define isalnum(c) (isalpha(c)||isdigit(c)) +#endif + + +/* + * The following table assigns a type to each character. Only types + * meaningful to Tcl parsing are represented here. The table indexes + * all 256 characters, with the negative ones first, then the positive + * ones. + */ + +char tclTypeTable[] = { + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_COMMAND_END, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_SPACE, TCL_COMMAND_END, TCL_SPACE, + TCL_SPACE, TCL_SPACE, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_SPACE, TCL_NORMAL, TCL_QUOTE, TCL_NORMAL, + TCL_DOLLAR, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_COMMAND_END, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_OPEN_BRACKET, + TCL_BACKSLASH, TCL_COMMAND_END, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_OPEN_BRACE, + TCL_NORMAL, TCL_CLOSE_BRACE, TCL_NORMAL, TCL_NORMAL, +}; + +/* + * Function prototypes for procedures local to this file: + */ + +static char * QuoteEnd _ANSI_ARGS_((char *string, int term)); +static char * VarNameEnd _ANSI_ARGS_((char *string)); + +/* + *---------------------------------------------------------------------- + * + * Tcl_Backslash -- + * + * Figure out how to handle a backslash sequence. + * + * Results: + * The return value is the character that should be substituted + * in place of the backslash sequence that starts at src. If + * readPtr isn't NULL then it is filled in with a count of the + * number of characters in the backslash sequence. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +char +Tcl_Backslash(src, readPtr) + char *src; /* Points to the backslash character of + * a backslash sequence. */ + int *readPtr; /* Fill in with number of characters read + * from src, unless NULL. */ +{ + register char *p = src+1; + char result; + int count; + + count = 2; + + switch (*p) { + case 'a': + result = 0x7; /* Don't say '\a' here, since some compilers */ + break; /* don't support it. */ + case 'b': + result = '\b'; + break; + case 'f': + result = '\f'; + break; + case 'n': + result = '\n'; + break; + case 'r': + result = '\r'; + break; + case 't': + result = '\t'; + break; + case 'v': + result = '\v'; + break; + case 'x': + if (isxdigit(UCHAR(p[1]))) { + char *end; + + result = strtoul(p+1, &end, 16); + count = end - src; + } else { + count = 2; + result = 'x'; + } + break; + case '\n': + do { + p++; + } while (isspace(UCHAR(*p))); + result = ' '; + count = p - src; + break; + case 0: + result = '\\'; + count = 1; + break; + default: + if (isdigit(UCHAR(*p))) { + result = *p - '0'; + p++; + if (!isdigit(UCHAR(*p))) { + break; + } + count = 3; + result = (result << 3) + (*p - '0'); + p++; + if (!isdigit(UCHAR(*p))) { + break; + } + count = 4; + result = (result << 3) + (*p - '0'); + break; + } + result = *p; + count = 2; + break; + } + + if (readPtr != NULL) { + *readPtr = count; + } + return result; +} + +/* + *-------------------------------------------------------------- + * + * TclParseQuotes -- + * + * This procedure parses a double-quoted string such as a + * quoted Tcl command argument or a quoted value in a Tcl + * expression. This procedure is also used to parse array + * element names within parentheses, or anything else that + * needs all the substitutions that happen in quotes. + * + * Results: + * The return value is a standard Tcl result, which is + * TCL_OK unless there was an error while parsing the + * quoted string. If an error occurs then interp->result + * contains a standard error message. *TermPtr is filled + * in with the address of the character just after the + * last one successfully processed; this is usually the + * character just after the matching close-quote. The + * fully-substituted contents of the quotes are stored in + * standard fashion in *pvPtr, null-terminated with + * pvPtr->next pointing to the terminating null character. + * + * Side effects: + * The buffer space in pvPtr may be enlarged by calling its + * expandProc. + * + *-------------------------------------------------------------- + */ + +int +TclParseQuotes(interp, string, termChar, flags, termPtr, pvPtr) + Tcl_Interp *interp; /* Interpreter to use for nested command + * evaluations and error messages. */ + char *string; /* Character just after opening double- + * quote. */ + int termChar; /* Character that terminates "quoted" string + * (usually double-quote, but sometimes + * right-paren or something else). */ + int flags; /* Flags to pass to nested Tcl_Eval calls. */ + char **termPtr; /* Store address of terminating character + * here. */ + ParseValue *pvPtr; /* Information about where to place + * fully-substituted result of parse. */ +{ + register char *src, *dst, c; + + src = string; + dst = pvPtr->next; + + while (1) { + if (dst == pvPtr->end) { + /* + * Target buffer space is about to run out. Make more space. + */ + + pvPtr->next = dst; + (*pvPtr->expandProc)(pvPtr, 1); + dst = pvPtr->next; + } + + c = *src; + src++; + if (c == termChar) { + *dst = '\0'; + pvPtr->next = dst; + *termPtr = src; + return TCL_OK; + } else if (CHAR_TYPE(c) == TCL_NORMAL) { + copy: + *dst = c; + dst++; + continue; + } else if (c == '$') { + int length; + char *value; + + value = Tcl_ParseVar(interp, src-1, termPtr); + if (value == NULL) { + return TCL_ERROR; + } + src = *termPtr; + length = strlen(value); + if ((pvPtr->end - dst) <= length) { + pvPtr->next = dst; + (*pvPtr->expandProc)(pvPtr, length); + dst = pvPtr->next; + } + strcpy(dst, value); + dst += length; + continue; + } else if (c == '[') { + int result; + + pvPtr->next = dst; + result = TclParseNestedCmd(interp, src, flags, termPtr, pvPtr); + if (result != TCL_OK) { + return result; + } + src = *termPtr; + dst = pvPtr->next; + continue; + } else if (c == '\\') { + int numRead; + + src--; + *dst = Tcl_Backslash(src, &numRead); + dst++; + src += numRead; + continue; + } else if (c == '\0') { + Tcl_ResetResult(interp); + sprintf(interp->result, "missing %c", termChar); + *termPtr = string-1; + return TCL_ERROR; + } else { + goto copy; + } + } +} + +/* + *-------------------------------------------------------------- + * + * TclParseNestedCmd -- + * + * This procedure parses a nested Tcl command between + * brackets, returning the result of the command. + * + * Results: + * The return value is a standard Tcl result, which is + * TCL_OK unless there was an error while executing the + * nested command. If an error occurs then interp->result + * contains a standard error message. *TermPtr is filled + * in with the address of the character just after the + * last one processed; this is usually the character just + * after the matching close-bracket, or the null character + * at the end of the string if the close-bracket was missing + * (a missing close bracket is an error). The result returned + * by the command is stored in standard fashion in *pvPtr, + * null-terminated, with pvPtr->next pointing to the null + * character. + * + * Side effects: + * The storage space at *pvPtr may be expanded. + * + *-------------------------------------------------------------- + */ + +int +TclParseNestedCmd(interp, string, flags, termPtr, pvPtr) + Tcl_Interp *interp; /* Interpreter to use for nested command + * evaluations and error messages. */ + char *string; /* Character just after opening bracket. */ + int flags; /* Flags to pass to nested Tcl_Eval. */ + char **termPtr; /* Store address of terminating character + * here. */ + register ParseValue *pvPtr; /* Information about where to place + * result of command. */ +{ + int result, length, shortfall; + Interp *iPtr = (Interp *) interp; + + iPtr->evalFlags = flags | TCL_BRACKET_TERM; + result = Tcl_Eval(interp, string); + *termPtr = iPtr->termPtr; + if (result != TCL_OK) { + /* + * The increment below results in slightly cleaner message in + * the errorInfo variable (the close-bracket will appear). + */ + + if (**termPtr == ']') { + *termPtr += 1; + } + return result; + } + (*termPtr) += 1; + length = strlen(iPtr->result); + shortfall = length + 1 - (pvPtr->end - pvPtr->next); + if (shortfall > 0) { + (*pvPtr->expandProc)(pvPtr, shortfall); + } + strcpy(pvPtr->next, iPtr->result); + pvPtr->next += length; + Tcl_FreeResult(iPtr); + iPtr->result = iPtr->resultSpace; + iPtr->resultSpace[0] = '\0'; + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * TclParseBraces -- + * + * This procedure scans the information between matching + * curly braces. + * + * Results: + * The return value is a standard Tcl result, which is + * TCL_OK unless there was an error while parsing string. + * If an error occurs then interp->result contains a + * standard error message. *TermPtr is filled + * in with the address of the character just after the + * last one successfully processed; this is usually the + * character just after the matching close-brace. The + * information between curly braces is stored in standard + * fashion in *pvPtr, null-terminated with pvPtr->next + * pointing to the terminating null character. + * + * Side effects: + * The storage space at *pvPtr may be expanded. + * + *-------------------------------------------------------------- + */ + +int +TclParseBraces(interp, string, termPtr, pvPtr) + Tcl_Interp *interp; /* Interpreter to use for nested command + * evaluations and error messages. */ + char *string; /* Character just after opening bracket. */ + char **termPtr; /* Store address of terminating character + * here. */ + register ParseValue *pvPtr; /* Information about where to place + * result of command. */ +{ + int level; + register char *src, *dst, *end; + register char c; + + src = string; + dst = pvPtr->next; + end = pvPtr->end; + level = 1; + + /* + * Copy the characters one at a time to the result area, stopping + * when the matching close-brace is found. + */ + + while (1) { + c = *src; + src++; + if (dst == end) { + pvPtr->next = dst; + (*pvPtr->expandProc)(pvPtr, 20); + dst = pvPtr->next; + end = pvPtr->end; + } + *dst = c; + dst++; + if (CHAR_TYPE(c) == TCL_NORMAL) { + continue; + } else if (c == '{') { + level++; + } else if (c == '}') { + level--; + if (level == 0) { + dst--; /* Don't copy the last close brace. */ + break; + } + } else if (c == '\\') { + int count; + + /* + * Must always squish out backslash-newlines, even when in + * braces. This is needed so that this sequence can appear + * anywhere in a command, such as the middle of an expression. + */ + + if (*src == '\n') { + dst[-1] = Tcl_Backslash(src-1, &count); + src += count - 1; + } else { + (void) Tcl_Backslash(src-1, &count); + while (count > 1) { + if (dst == end) { + pvPtr->next = dst; + (*pvPtr->expandProc)(pvPtr, 20); + dst = pvPtr->next; + end = pvPtr->end; + } + *dst = *src; + dst++; + src++; + count--; + } + } + } else if (c == '\0') { + Tcl_SetResult(interp, "missing close-brace", TCL_STATIC); + *termPtr = string-1; + return TCL_ERROR; + } + } + + *dst = '\0'; + pvPtr->next = dst; + *termPtr = src; + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * TclParseWords -- + * + * This procedure parses one or more words from a command + * string and creates argv-style pointers to fully-substituted + * copies of those words. + * + * Results: + * The return value is a standard Tcl result. + * + * *argcPtr is modified to hold a count of the number of words + * successfully parsed, which may be 0. At most maxWords words + * will be parsed. If 0 <= *argcPtr < maxWords then it + * means that a command separator was seen. If *argcPtr + * is maxWords then it means that a command separator was + * not seen yet. + * + * *TermPtr is filled in with the address of the character + * just after the last one successfully processed in the + * last word. This is either the command terminator (if + * *argcPtr < maxWords), the character just after the last + * one in a word (if *argcPtr is maxWords), or the vicinity + * of an error (if the result is not TCL_OK). + * + * The pointers at *argv are filled in with pointers to the + * fully-substituted words, and the actual contents of the + * words are copied to the buffer at pvPtr. + * + * If an error occurrs then an error message is left in + * interp->result and the information at *argv, *argcPtr, + * and *pvPtr may be incomplete. + * + * Side effects: + * The buffer space in pvPtr may be enlarged by calling its + * expandProc. + * + *-------------------------------------------------------------- + */ + +int +TclParseWords(interp, string, flags, maxWords, termPtr, argcPtr, argv, pvPtr) + Tcl_Interp *interp; /* Interpreter to use for nested command + * evaluations and error messages. */ + char *string; /* First character of word. */ + int flags; /* Flags to control parsing (same values as + * passed to Tcl_Eval). */ + int maxWords; /* Maximum number of words to parse. */ + char **termPtr; /* Store address of terminating character + * here. */ + int *argcPtr; /* Filled in with actual number of words + * parsed. */ + char **argv; /* Store addresses of individual words here. */ + register ParseValue *pvPtr; /* Information about where to place + * fully-substituted word. */ +{ + register char *src, *dst; + register char c; + int type, result, argc; + char *oldBuffer; /* Used to detect when pvPtr's buffer gets + * reallocated, so we can adjust all of the + * argv pointers. */ + + src = string; + oldBuffer = pvPtr->buffer; + dst = pvPtr->next; + for (argc = 0; argc < maxWords; argc++) { + argv[argc] = dst; + + /* + * Skip leading space. + */ + + skipSpace: + c = *src; + type = CHAR_TYPE(c); + while (type == TCL_SPACE) { + src++; + c = *src; + type = CHAR_TYPE(c); + } + + /* + * Handle the normal case (i.e. no leading double-quote or brace). + */ + + if (type == TCL_NORMAL) { + normalArg: + while (1) { + if (dst == pvPtr->end) { + /* + * Target buffer space is about to run out. Make + * more space. + */ + + pvPtr->next = dst; + (*pvPtr->expandProc)(pvPtr, 1); + dst = pvPtr->next; + } + + if (type == TCL_NORMAL) { + copy: + *dst = c; + dst++; + src++; + } else if (type == TCL_SPACE) { + goto wordEnd; + } else if (type == TCL_DOLLAR) { + int length; + char *value; + + value = Tcl_ParseVar(interp, src, termPtr); + if (value == NULL) { + return TCL_ERROR; + } + src = *termPtr; + length = strlen(value); + if ((pvPtr->end - dst) <= length) { + pvPtr->next = dst; + (*pvPtr->expandProc)(pvPtr, length); + dst = pvPtr->next; + } + strcpy(dst, value); + dst += length; + } else if (type == TCL_COMMAND_END) { + if ((c == ']') && !(flags & TCL_BRACKET_TERM)) { + goto copy; + } + + /* + * End of command; simulate a word-end first, so + * that the end-of-command can be processed as the + * first thing in a new word. + */ + + goto wordEnd; + } else if (type == TCL_OPEN_BRACKET) { + pvPtr->next = dst; + result = TclParseNestedCmd(interp, src+1, flags, termPtr, + pvPtr); + if (result != TCL_OK) { + return result; + } + src = *termPtr; + dst = pvPtr->next; + } else if (type == TCL_BACKSLASH) { + int numRead; + + *dst = Tcl_Backslash(src, &numRead); + + /* + * The following special check allows a backslash-newline + * to be treated as a word-separator, as if the backslash + * and newline had been collapsed before command parsing + * began. + */ + + if (src[1] == '\n') { + src += numRead; + goto wordEnd; + } + src += numRead; + dst++; + } else { + goto copy; + } + c = *src; + type = CHAR_TYPE(c); + } + } else { + + /* + * Check for the end of the command. + */ + + if (type == TCL_COMMAND_END) { + if (flags & TCL_BRACKET_TERM) { + if (c == '\0') { + Tcl_SetResult(interp, "missing close-bracket", + TCL_STATIC); + return TCL_ERROR; + } + } else { + if (c == ']') { + goto normalArg; + } + } + goto done; + } + + /* + * Now handle the special cases: open braces, double-quotes, + * and backslash-newline. + */ + + pvPtr->next = dst; + if (type == TCL_QUOTE) { + result = TclParseQuotes(interp, src+1, '"', flags, + termPtr, pvPtr); + } else if (type == TCL_OPEN_BRACE) { + result = TclParseBraces(interp, src+1, termPtr, pvPtr); + } else if ((type == TCL_BACKSLASH) && (src[1] == '\n')) { + /* + * This code is needed so that a backslash-newline at the + * very beginning of a word is treated as part of the white + * space between words and not as a space within the word. + */ + + src += 2; + goto skipSpace; + } else { + goto normalArg; + } + if (result != TCL_OK) { + return result; + } + + /* + * Back from quotes or braces; make sure that the terminating + * character was the end of the word. Have to be careful here + * to handle continuation lines (i.e. lines ending in backslash). + */ + + c = **termPtr; + if ((c == '\\') && ((*termPtr)[1] == '\n')) { + c = (*termPtr)[2]; + } + type = CHAR_TYPE(c); + if ((type != TCL_SPACE) && (type != TCL_COMMAND_END)) { + if (*src == '"') { + Tcl_SetResult(interp, "extra characters after close-quote", + TCL_STATIC); + } else { + Tcl_SetResult(interp, "extra characters after close-brace", + TCL_STATIC); + } + return TCL_ERROR; + } + src = *termPtr; + dst = pvPtr->next; + + } + + /* + * We're at the end of a word, so add a null terminator. Then + * see if the buffer was re-allocated during this word. If so, + * update all of the argv pointers. + */ + + wordEnd: + *dst = '\0'; + dst++; + if (oldBuffer != pvPtr->buffer) { + int i; + + for (i = 0; i <= argc; i++) { + argv[i] = pvPtr->buffer + (argv[i] - oldBuffer); + } + oldBuffer = pvPtr->buffer; + } + } + + done: + pvPtr->next = dst; + *termPtr = src; + *argcPtr = argc; + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * TclExpandParseValue -- + * + * This procedure is commonly used as the value of the + * expandProc in a ParseValue. It uses malloc to allocate + * more space for the result of a parse. + * + * Results: + * The buffer space in *pvPtr is reallocated to something + * larger, and if pvPtr->clientData is non-zero the old + * buffer is freed. Information is copied from the old + * buffer to the new one. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +void +TclExpandParseValue(pvPtr, needed) + register ParseValue *pvPtr; /* Information about buffer that + * must be expanded. If the clientData + * in the structure is non-zero, it + * means that the current buffer is + * dynamically allocated. */ + int needed; /* Minimum amount of additional space + * to allocate. */ +{ + int newSpace; + char *new; + + /* + * Either double the size of the buffer or add enough new space + * to meet the demand, whichever produces a larger new buffer. + */ + + newSpace = (pvPtr->end - pvPtr->buffer) + 1; + if (newSpace < needed) { + newSpace += needed; + } else { + newSpace += newSpace; + } + new = (char *) ckalloc((unsigned) newSpace); + + /* + * Copy from old buffer to new, free old buffer if needed, and + * mark new buffer as malloc-ed. + */ + + memcpy((VOID *) new, (VOID *) pvPtr->buffer, pvPtr->next - pvPtr->buffer); + pvPtr->next = new + (pvPtr->next - pvPtr->buffer); + if (pvPtr->clientData != 0) { + ckfree(pvPtr->buffer); + } + pvPtr->buffer = new; + pvPtr->end = new + newSpace - 1; + pvPtr->clientData = (ClientData) 1; +} + +/* + *---------------------------------------------------------------------- + * + * TclWordEnd -- + * + * Given a pointer into a Tcl command, find the end of the next + * word of the command. + * + * Results: + * The return value is a pointer to the last character that's part + * of the word pointed to by "start". If the word doesn't end + * properly within the string then the return value is the address + * of the null character at the end of the string. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +char * +TclWordEnd(start, nested, semiPtr) + char *start; /* Beginning of a word of a Tcl command. */ + int nested; /* Zero means this is a top-level command. + * One means this is a nested command (close + * brace is a word terminator). */ + int *semiPtr; /* Set to 1 if word ends with a command- + * terminating semi-colon, zero otherwise. + * If NULL then ignored. */ +{ + register char *p; + int count; + + if (semiPtr != NULL) { + *semiPtr = 0; + } + + /* + * Skip leading white space (backslash-newline must be treated like + * white-space, except that it better not be the last thing in the + * command). + */ + + for (p = start; ; p++) { + if (isspace(UCHAR(*p))) { + continue; + } + if ((p[0] == '\\') && (p[1] == '\n')) { + if (p[2] == 0) { + return p+2; + } + continue; + } + break; + } + + /* + * Handle words beginning with a double-quote or a brace. + */ + + if (*p == '"') { + p = QuoteEnd(p+1, '"'); + if (*p == 0) { + return p; + } + p++; + } else if (*p == '{') { + int braces = 1; + while (braces != 0) { + p++; + while (*p == '\\') { + (void) Tcl_Backslash(p, &count); + p += count; + } + if (*p == '}') { + braces--; + } else if (*p == '{') { + braces++; + } else if (*p == 0) { + return p; + } + } + p++; + } + + /* + * Handle words that don't start with a brace or double-quote. + * This code is also invoked if the word starts with a brace or + * double-quote and there is garbage after the closing brace or + * quote. This is an error as far as Tcl_Eval is concerned, but + * for here the garbage is treated as part of the word. + */ + + while (1) { + if (*p == '[') { + for (p++; *p != ']'; p++) { + p = TclWordEnd(p, 1, (int *) NULL); + if (*p == 0) { + return p; + } + } + p++; + } else if (*p == '\\') { + (void) Tcl_Backslash(p, &count); + p += count; + if ((*p == 0) && (count == 2) && (p[-1] == '\n')) { + return p; + } + } else if (*p == '$') { + p = VarNameEnd(p); + if (*p == 0) { + return p; + } + p++; + } else if (*p == ';') { + /* + * Include the semi-colon in the word that is returned. + */ + + if (semiPtr != NULL) { + *semiPtr = 1; + } + return p; + } else if (isspace(UCHAR(*p))) { + return p-1; + } else if ((*p == ']') && nested) { + return p-1; + } else if (*p == 0) { + if (nested) { + /* + * Nested commands can't end because of the end of the + * string. + */ + return p; + } + return p-1; + } else { + p++; + } + } +} + +/* + *---------------------------------------------------------------------- + * + * QuoteEnd -- + * + * Given a pointer to a string that obeys the parsing conventions + * for quoted things in Tcl, find the end of that quoted thing. + * The actual thing may be a quoted argument or a parenthesized + * index name. + * + * Results: + * The return value is a pointer to the last character that is + * part of the quoted string (i.e the character that's equal to + * term). If the quoted string doesn't terminate properly then + * the return value is a pointer to the null character at the + * end of the string. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static char * +QuoteEnd(string, term) + char *string; /* Pointer to character just after opening + * "quote". */ + int term; /* This character will terminate the + * quoted string (e.g. '"' or ')'). */ +{ + register char *p = string; + int count; + + while (*p != term) { + if (*p == '\\') { + (void) Tcl_Backslash(p, &count); + p += count; + } else if (*p == '[') { + for (p++; *p != ']'; p++) { + p = TclWordEnd(p, 1, (int *) NULL); + if (*p == 0) { + return p; + } + } + p++; + } else if (*p == '$') { + p = VarNameEnd(p); + if (*p == 0) { + return p; + } + p++; + } else if (*p == 0) { + return p; + } else { + p++; + } + } + return p-1; +} + +/* + *---------------------------------------------------------------------- + * + * VarNameEnd -- + * + * Given a pointer to a variable reference using $-notation, find + * the end of the variable name spec. + * + * Results: + * The return value is a pointer to the last character that + * is part of the variable name. If the variable name doesn't + * terminate properly then the return value is a pointer to the + * null character at the end of the string. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static char * +VarNameEnd(string) + char *string; /* Pointer to dollar-sign character. */ +{ + register char *p = string+1; + + if (*p == '{') { + for (p++; (*p != '}') && (*p != 0); p++) { + /* Empty loop body. */ + } + return p; + } + while (isalnum(UCHAR(*p)) || (*p == '_')) { + p++; + } + if ((*p == '(') && (p != string+1)) { + return QuoteEnd(p+1, ')'); + } + return p-1; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ParseVar -- + * + * Given a string starting with a $ sign, parse off a variable + * name and return its value. + * + * Results: + * The return value is the contents of the variable given by + * the leading characters of string. If termPtr isn't NULL, + * *termPtr gets filled in with the address of the character + * just after the last one in the variable specifier. If the + * variable doesn't exist, then the return value is NULL and + * an error message will be left in interp->result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_ParseVar(interp, string, termPtr) + Tcl_Interp *interp; /* Context for looking up variable. */ + register char *string; /* String containing variable name. + * First character must be "$". */ + char **termPtr; /* If non-NULL, points to word to fill + * in with character just after last + * one in the variable specifier. */ + +{ + char *name1, *name1End, c, *result; + register char *name2; +#define NUM_CHARS 200 + char copyStorage[NUM_CHARS]; + ParseValue pv; + + /* + * There are three cases: + * 1. The $ sign is followed by an open curly brace. Then the variable + * name is everything up to the next close curly brace, and the + * variable is a scalar variable. + * 2. The $ sign is not followed by an open curly brace. Then the + * variable name is everything up to the next character that isn't + * a letter, digit, or underscore. If the following character is an + * open parenthesis, then the information between parentheses is + * the array element name, which can include any of the substitutions + * permissible between quotes. + * 3. The $ sign is followed by something that isn't a letter, digit, + * or underscore: in this case, there is no variable name, and "$" + * is returned. + */ + + name2 = NULL; + string++; + if (*string == '{') { + string++; + name1 = string; + while (*string != '}') { + if (*string == 0) { + Tcl_SetResult(interp, "missing close-brace for variable name", + TCL_STATIC); + if (termPtr != 0) { + *termPtr = string; + } + return NULL; + } + string++; + } + name1End = string; + string++; + } else { + name1 = string; + while (isalnum(UCHAR(*string)) || (*string == '_')) { + string++; + } + if (string == name1) { + if (termPtr != 0) { + *termPtr = string; + } + return "$"; + } + name1End = string; + if (*string == '(') { + char *end; + + /* + * Perform substitutions on the array element name, just as + * is done for quotes. + */ + + pv.buffer = pv.next = copyStorage; + pv.end = copyStorage + NUM_CHARS - 1; + pv.expandProc = TclExpandParseValue; + pv.clientData = (ClientData) NULL; + if (TclParseQuotes(interp, string+1, ')', 0, &end, &pv) + != TCL_OK) { + char msg[100]; + sprintf(msg, "\n (parsing index for array \"%.*s\")", + string-name1, name1); + Tcl_AddErrorInfo(interp, msg); + result = NULL; + name2 = pv.buffer; + if (termPtr != 0) { + *termPtr = end; + } + goto done; + } + Tcl_ResetResult(interp); + string = end; + name2 = pv.buffer; + } + } + if (termPtr != 0) { + *termPtr = string; + } + + if (((Interp *) interp)->noEval) { + return ""; + } + c = *name1End; + *name1End = 0; + result = Tcl_GetVar2(interp, name1, name2, TCL_LEAVE_ERR_MSG); + *name1End = c; + + done: + if ((name2 != NULL) && (pv.buffer != copyStorage)) { + ckfree(pv.buffer); + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_CommandComplete -- + * + * Given a partial or complete Tcl command, this procedure + * determines whether the command is complete in the sense + * of having matched braces and quotes and brackets. + * + * Results: + * 1 is returned if the command is complete, 0 otherwise. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_CommandComplete(cmd) + char *cmd; /* Command to check. */ +{ + register char *p = cmd; + int commentOK = 1; + + while (1) { + while (isspace(UCHAR(*p))) { + if (*p == '\n') { + commentOK = 1; + } + p++; + } + if ((*p == '#') && commentOK) { + do { + p++; + } while ((*p != '\n') && (*p != 0)); + continue; + } + if (*p == 0) { + return 1; + } + p = TclWordEnd(p, 0, &commentOK); + if (*p == 0) { + return 0; + } + p++; + } +} diff --git a/vendor/x11iraf/obm/Tcl/tclProc.c b/vendor/x11iraf/obm/Tcl/tclProc.c new file mode 100644 index 00000000..6d290c51 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/tclProc.c @@ -0,0 +1,625 @@ +/* + * tclProc.c -- + * + * This file contains routines that implement Tcl procedures, + * including the "proc" and "uplevel" commands. + * + * Copyright (c) 1987-1993 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. + */ + +#ifndef lint +static char rcsid[] = "$Header: /user6/ouster/tcl/RCS/tclProc.c,v 1.68 93/10/14 15:13:55 ouster Exp $ SPRITE (Berkeley)"; +#endif + +#include "tclInt.h" + +/* + * Forward references to procedures defined later in this file: + */ + +static void CleanupProc _ANSI_ARGS_((Proc *procPtr)); +static int InterpProc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +static void ProcDeleteProc _ANSI_ARGS_((ClientData clientData)); + +/* + *---------------------------------------------------------------------- + * + * Tcl_ProcCmd -- + * + * This procedure is invoked to process the "proc" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result value. + * + * Side effects: + * A new procedure gets created. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_ProcCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + register Interp *iPtr = (Interp *) interp; + register Proc *procPtr; + int result, argCount, i; + char **argArray = NULL; + Arg *lastArgPtr; + register Arg *argPtr = NULL; /* Initialization not needed, but + * prevents compiler warning. */ + + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " name args body\"", (char *) NULL); + return TCL_ERROR; + } + + procPtr = (Proc *) ckalloc(sizeof(Proc)); + procPtr->iPtr = iPtr; + procPtr->refCount = 1; + procPtr->command = (char *) ckalloc((unsigned) strlen(argv[3]) + 1); + strcpy(procPtr->command, argv[3]); + procPtr->argPtr = NULL; + + /* + * Break up the argument list into argument specifiers, then process + * each argument specifier. + */ + + result = Tcl_SplitList(interp, argv[2], &argCount, &argArray); + if (result != TCL_OK) { + goto procError; + } + lastArgPtr = NULL; + for (i = 0; i < argCount; i++) { + int fieldCount, nameLength, valueLength; + char **fieldValues; + + /* + * Now divide the specifier up into name and default. + */ + + result = Tcl_SplitList(interp, argArray[i], &fieldCount, + &fieldValues); + if (result != TCL_OK) { + goto procError; + } + if (fieldCount > 2) { + ckfree((char *) fieldValues); + Tcl_AppendResult(interp, + "too many fields in argument specifier \"", + argArray[i], "\"", (char *) NULL); + result = TCL_ERROR; + goto procError; + } + if ((fieldCount == 0) || (*fieldValues[0] == 0)) { + ckfree((char *) fieldValues); + Tcl_AppendResult(interp, "procedure \"", argv[1], + "\" has argument with no name", (char *) NULL); + result = TCL_ERROR; + goto procError; + } + nameLength = strlen(fieldValues[0]) + 1; + if (fieldCount == 2) { + valueLength = strlen(fieldValues[1]) + 1; + } else { + valueLength = 0; + } + argPtr = (Arg *) ckalloc((unsigned) + (sizeof(Arg) - sizeof(argPtr->name) + nameLength + + valueLength)); + if (lastArgPtr == NULL) { + procPtr->argPtr = argPtr; + } else { + lastArgPtr->nextPtr = argPtr; + } + lastArgPtr = argPtr; + argPtr->nextPtr = NULL; + strcpy(argPtr->name, fieldValues[0]); + if (fieldCount == 2) { + argPtr->defValue = argPtr->name + nameLength; + strcpy(argPtr->defValue, fieldValues[1]); + } else { + argPtr->defValue = NULL; + } + ckfree((char *) fieldValues); + } + + Tcl_CreateCommand(interp, argv[1], InterpProc, (ClientData) procPtr, + ProcDeleteProc); + ckfree((char *) argArray); + return TCL_OK; + + procError: + ckfree(procPtr->command); + while (procPtr->argPtr != NULL) { + argPtr = procPtr->argPtr; + procPtr->argPtr = argPtr->nextPtr; + ckfree((char *) argPtr); + } + ckfree((char *) procPtr); + if (argArray != NULL) { + ckfree((char *) argArray); + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * TclGetFrame -- + * + * Given a description of a procedure frame, such as the first + * argument to an "uplevel" or "upvar" command, locate the + * call frame for the appropriate level of procedure. + * + * Results: + * The return value is -1 if an error occurred in finding the + * frame (in this case an error message is left in interp->result). + * 1 is returned if string was either a number or a number preceded + * by "#" and it specified a valid frame. 0 is returned if string + * isn't one of the two things above (in this case, the lookup + * acts as if string were "1"). The variable pointed to by + * framePtrPtr is filled in with the address of the desired frame + * (unless an error occurs, in which case it isn't modified). + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclGetFrame(interp, string, framePtrPtr) + Tcl_Interp *interp; /* Interpreter in which to find frame. */ + char *string; /* String describing frame. */ + CallFrame **framePtrPtr; /* Store pointer to frame here (or NULL + * if global frame indicated). */ +{ + register Interp *iPtr = (Interp *) interp; + int curLevel, level, result; + CallFrame *framePtr; + + /* + * Parse string to figure out which level number to go to. + */ + + result = 1; + curLevel = (iPtr->varFramePtr == NULL) ? 0 : iPtr->varFramePtr->level; + if (*string == '#') { + if (Tcl_GetInt(interp, string+1, &level) != TCL_OK) { + return -1; + } + if (level < 0) { + levelError: + Tcl_AppendResult(interp, "bad level \"", string, "\"", + (char *) NULL); + return -1; + } + } else if (isdigit(UCHAR(*string))) { + if (Tcl_GetInt(interp, string, &level) != TCL_OK) { + return -1; + } + level = curLevel - level; + } else { + level = curLevel - 1; + result = 0; + } + + /* + * Figure out which frame to use, and modify the interpreter so + * its variables come from that frame. + */ + + if (level == 0) { + framePtr = NULL; + } else { + for (framePtr = iPtr->varFramePtr; framePtr != NULL; + framePtr = framePtr->callerVarPtr) { + if (framePtr->level == level) { + break; + } + } + if (framePtr == NULL) { + goto levelError; + } + } + *framePtrPtr = framePtr; + return result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_UplevelCmd -- + * + * This procedure is invoked to process the "uplevel" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result value. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_UplevelCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + register Interp *iPtr = (Interp *) interp; + int result; + CallFrame *savedVarFramePtr, *framePtr; + + if (argc < 2) { + uplevelSyntax: + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " ?level? command ?arg ...?\"", (char *) NULL); + return TCL_ERROR; + } + + /* + * Find the level to use for executing the command. + */ + + result = TclGetFrame(interp, argv[1], &framePtr); + if (result == -1) { + return TCL_ERROR; + } + argc -= (result+1); + if (argc == 0) { + goto uplevelSyntax; + } + argv += (result+1); + + /* + * Modify the interpreter state to execute in the given frame. + */ + + savedVarFramePtr = iPtr->varFramePtr; + iPtr->varFramePtr = framePtr; + + /* + * Execute the residual arguments as a command. + */ + + if (argc == 1) { + result = Tcl_Eval(interp, argv[0]); + } else { + char *cmd; + + cmd = Tcl_Concat(argc, argv); + result = Tcl_Eval(interp, cmd); + ckfree(cmd); + } + if (result == TCL_ERROR) { + char msg[60]; + sprintf(msg, "\n (\"uplevel\" body line %d)", interp->errorLine); + Tcl_AddErrorInfo(interp, msg); + } + + /* + * Restore the variable frame, and return. + */ + + iPtr->varFramePtr = savedVarFramePtr; + return result; +} + +/* + *---------------------------------------------------------------------- + * + * TclFindProc -- + * + * Given the name of a procedure, return a pointer to the + * record describing the procedure. + * + * Results: + * NULL is returned if the name doesn't correspond to any + * procedure. Otherwise the return value is a pointer to + * the procedure's record. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Proc * +TclFindProc(iPtr, procName) + Interp *iPtr; /* Interpreter in which to look. */ + char *procName; /* Name of desired procedure. */ +{ + Tcl_HashEntry *hPtr; + Command *cmdPtr; + + hPtr = Tcl_FindHashEntry(&iPtr->commandTable, procName); + if (hPtr == NULL) { + return NULL; + } + cmdPtr = (Command *) Tcl_GetHashValue(hPtr); + if (cmdPtr->proc != InterpProc) { + return NULL; + } + return (Proc *) cmdPtr->clientData; +} + +/* + *---------------------------------------------------------------------- + * + * TclIsProc -- + * + * Tells whether a command is a Tcl procedure or not. + * + * Results: + * If the given command is actuall a Tcl procedure, the + * return value is the address of the record describing + * the procedure. Otherwise the return value is 0. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Proc * +TclIsProc(cmdPtr) + Command *cmdPtr; /* Command to test. */ +{ + if (cmdPtr->proc == InterpProc) { + return (Proc *) cmdPtr->clientData; + } + return (Proc *) 0; +} + +/* + *---------------------------------------------------------------------- + * + * InterpProc -- + * + * When a Tcl procedure gets invoked, this routine gets invoked + * to interpret the procedure. + * + * Results: + * A standard Tcl result value, usually TCL_OK. + * + * Side effects: + * Depends on the commands in the procedure. + * + *---------------------------------------------------------------------- + */ + +static int +InterpProc(clientData, interp, argc, argv) + ClientData clientData; /* Record describing procedure to be + * interpreted. */ + Tcl_Interp *interp; /* Interpreter in which procedure was + * invoked. */ + int argc; /* Count of number of arguments to this + * procedure. */ + char **argv; /* Argument values. */ +{ + register Proc *procPtr = (Proc *) clientData; + register Arg *argPtr; + register Interp *iPtr; + char **args; + CallFrame frame; + char *value; + int result; + + /* + * Set up a call frame for the new procedure invocation. + */ + + iPtr = procPtr->iPtr; + Tcl_InitHashTable(&frame.varTable, TCL_STRING_KEYS); + if (iPtr->varFramePtr != NULL) { + frame.level = iPtr->varFramePtr->level + 1; + } else { + frame.level = 1; + } + frame.argc = argc; + frame.argv = argv; + frame.callerPtr = iPtr->framePtr; + frame.callerVarPtr = iPtr->varFramePtr; + iPtr->framePtr = &frame; + iPtr->varFramePtr = &frame; + iPtr->returnCode = TCL_OK; + + /* + * Match the actual arguments against the procedure's formal + * parameters to compute local variables. + */ + + for (argPtr = procPtr->argPtr, args = argv+1, argc -= 1; + argPtr != NULL; + argPtr = argPtr->nextPtr, args++, argc--) { + + /* + * Handle the special case of the last formal being "args". When + * it occurs, assign it a list consisting of all the remaining + * actual arguments. + */ + + if ((argPtr->nextPtr == NULL) + && (strcmp(argPtr->name, "args") == 0)) { + if (argc < 0) { + argc = 0; + } + value = Tcl_Merge(argc, args); + Tcl_SetVar(interp, argPtr->name, value, 0); + ckfree(value); + argc = 0; + break; + } else if (argc > 0) { + value = *args; + } else if (argPtr->defValue != NULL) { + value = argPtr->defValue; + } else { + Tcl_AppendResult(interp, "no value given for parameter \"", + argPtr->name, "\" to \"", argv[0], "\"", + (char *) NULL); + result = TCL_ERROR; + goto procDone; + } + Tcl_SetVar(interp, argPtr->name, value, 0); + } + if (argc > 0) { + Tcl_AppendResult(interp, "called \"", argv[0], + "\" with too many arguments", (char *) NULL); + result = TCL_ERROR; + goto procDone; + } + + /* + * Invoke the commands in the procedure's body. + */ + + procPtr->refCount++; + result = Tcl_Eval(interp, procPtr->command); + procPtr->refCount--; + if (procPtr->refCount <= 0) { + CleanupProc(procPtr); + } + if (result == TCL_RETURN) { + result = iPtr->returnCode; + iPtr->returnCode = TCL_OK; + if (result == TCL_ERROR) { + Tcl_SetVar2(interp, "errorCode", (char *) NULL, + (iPtr->errorCode != NULL) ? iPtr->errorCode : "NONE", + TCL_GLOBAL_ONLY); + iPtr->flags |= ERROR_CODE_SET; + if (iPtr->errorInfo != NULL) { + Tcl_SetVar2(interp, "errorInfo", (char *) NULL, + iPtr->errorInfo, TCL_GLOBAL_ONLY); + iPtr->flags |= ERR_IN_PROGRESS; + } + } + } else if (result == TCL_ERROR) { + char msg[100]; + + /* + * Record information telling where the error occurred. + */ + + sprintf(msg, "\n (procedure \"%.50s\" line %d)", argv[0], + iPtr->errorLine); + Tcl_AddErrorInfo(interp, msg); + } else if (result == TCL_BREAK) { + iPtr->result = "invoked \"break\" outside of a loop"; + result = TCL_ERROR; + } else if (result == TCL_CONTINUE) { + iPtr->result = "invoked \"continue\" outside of a loop"; + result = TCL_ERROR; + } + + /* + * Delete the call frame for this procedure invocation (it's + * important to remove the call frame from the interpreter + * before deleting it, so that traces invoked during the + * deletion don't see the partially-deleted frame). + */ + + procDone: + iPtr->framePtr = frame.callerPtr; + iPtr->varFramePtr = frame.callerVarPtr; + TclDeleteVars(iPtr, &frame.varTable); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * ProcDeleteProc -- + * + * This procedure is invoked just before a command procedure is + * removed from an interpreter. Its job is to release all the + * resources allocated to the procedure. + * + * Results: + * None. + * + * Side effects: + * Memory gets freed, unless the procedure is actively being + * executed. In this case the cleanup is delayed until the + * last call to the current procedure completes. + * + *---------------------------------------------------------------------- + */ + +static void +ProcDeleteProc(clientData) + ClientData clientData; /* Procedure to be deleted. */ +{ + Proc *procPtr = (Proc *) clientData; + + procPtr->refCount--; + if (procPtr->refCount <= 0) { + CleanupProc(procPtr); + } +} + +/* + *---------------------------------------------------------------------- + * + * CleanupProc -- + * + * This procedure does all the real work of freeing up a Proc + * structure. It's called only when the structure's reference + * count becomes zero. + * + * Results: + * None. + * + * Side effects: + * Memory gets freed. + * + *---------------------------------------------------------------------- + */ + +static void +CleanupProc(procPtr) + register Proc *procPtr; /* Procedure to be deleted. */ +{ + register Arg *argPtr; + + ckfree((char *) procPtr->command); + for (argPtr = procPtr->argPtr; argPtr != NULL; ) { + Arg *nextPtr = argPtr->nextPtr; + + ckfree((char *) argPtr); + argPtr = nextPtr; + } + ckfree((char *) procPtr); +} diff --git a/vendor/x11iraf/obm/Tcl/tclRegexp.h b/vendor/x11iraf/obm/Tcl/tclRegexp.h new file mode 100644 index 00000000..c3460006 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/tclRegexp.h @@ -0,0 +1,30 @@ +/* + * Definitions etc. for regexp(3) routines. + * + * Caveat: this is V8 regexp(3) [actually, a reimplementation thereof], + * not the System V one. + */ + +#ifndef _TCL +#include "tcl.h" +#endif +#ifndef _REGEXP +#define _REGEXP 1 + +#define NSUBEXP 10 +typedef struct regexp { + char *startp[NSUBEXP]; + char *endp[NSUBEXP]; + char regstart; /* Internal use only. */ + char reganch; /* Internal use only. */ + char *regmust; /* Internal use only. */ + int regmlen; /* Internal use only. */ + char program[1]; /* Unwarranted chumminess with compiler. */ +} regexp; + +extern regexp *TclRegComp _ANSI_ARGS_((char *exp)); +extern int TclRegExec _ANSI_ARGS_((regexp *prog, char *string, char *start)); +extern void TclRegSub _ANSI_ARGS_((regexp *prog, char *source, char *dest)); +extern void TclRegError _ANSI_ARGS_((char *msg)); + +#endif /* REGEXP */ diff --git a/vendor/x11iraf/obm/Tcl/tclTest.c b/vendor/x11iraf/obm/Tcl/tclTest.c new file mode 100644 index 00000000..c3b19f35 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/tclTest.c @@ -0,0 +1,786 @@ +/* + * tclTest.c -- + * + * This file contains C command procedures for a bunch of additional + * Tcl commands that are used for testing out Tcl's C interfaces. + * These commands are not normally included in Tcl applications; + * they're only used for testing. + * + * Copyright (c) 1993 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. + */ + +#ifndef lint +static char rcsid[] = "$Header: /user6/ouster/tcl/RCS/tclTest.c,v 1.15 93/09/09 16:46:52 ouster Exp $ SPRITE (Berkeley)"; +#endif /* not lint */ + +#include "tclInt.h" +#include "tclUnix.h" + +/* + * The following variable is a special hack that allows applications + * to be linked using the procedure "main" from the Tcl library. The + * variable generates a reference to "main", which causes main to + * be brought in from the library (and all of Tcl with it). + */ + +extern int main(); +int *tclDummyMainPtr = (int *) main; + +/* + * Dynamic string shared by TestdcallCmd and DelCallbackProc; used + * to collect the results of the various deletion callbacks. + */ + +static Tcl_DString delString; +static Tcl_Interp *delInterp; + +/* + * One of the following structures exists for each asynchronous + * handler created by the "testasync" command". + */ + +typedef struct TestAsyncHandler { + int id; /* Identifier for this handler. */ + Tcl_AsyncHandler handler; /* Tcl's token for the handler. */ + char *command; /* Command to invoke when the + * handler is invoked. */ + struct TestAsyncHandler *nextPtr; /* Next is list of handlers. */ +} TestAsyncHandler; + +static TestAsyncHandler *firstHandler = NULL; + +/* + * The variable below is a token for an asynchronous handler for + * interrupt signals, or NULL if none exists. + */ + +static Tcl_AsyncHandler intHandler; + +/* + * The dynamic string below is used by the "testdstring" command + * to test the dynamic string facilities. + */ + +static Tcl_DString dstring; + +/* + * Forward declarations for procedures defined later in this file: + */ + +static int AsyncHandlerProc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int code)); +static void CmdDelProc1 _ANSI_ARGS_((ClientData clientData)); +static void CmdDelProc2 _ANSI_ARGS_((ClientData clientData)); +static int CmdProc1 _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +static int CmdProc2 _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +static void DelCallbackProc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp)); +static int IntHandlerProc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int code)); +static void IntProc(); +static int TestasyncCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestcmdinfoCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestdcallCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestdstringCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestlinkCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestMathFunc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, Tcl_Value *args, + Tcl_Value *resultPtr)); + +/* + *---------------------------------------------------------------------- + * + * Tcl_AppInit -- + * + * This procedure performs application-specific initialization. + * Most applications, especially those that incorporate additional + * packages, will have their own version of this procedure. + * + * Results: + * Returns a standard Tcl completion code, and leaves an error + * message in interp->result if an error occurs. + * + * Side effects: + * Depends on the startup script. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_AppInit(interp) + Tcl_Interp *interp; /* Interpreter for application. */ +{ + /* + * Call the init procedures for included packages. Each call should + * look like this: + * + * if (Mod_Init(interp) == TCL_ERROR) { + * return TCL_ERROR; + * } + * + * where "Mod" is the name of the module. + */ + + if (Tcl_Init(interp) == TCL_ERROR) { + return TCL_ERROR; + } + + /* + * Create additional commands and math functions for testing Tcl. + */ + + Tcl_CreateCommand(interp, "testasync", TestasyncCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testcmdinfo", TestcmdinfoCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testdcall", TestdcallCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + Tcl_DStringInit(&dstring); + Tcl_CreateCommand(interp, "testdstring", TestdstringCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testlink", TestlinkCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateMathFunc(interp, "T1", 0, (Tcl_ValueType *) NULL, TestMathFunc, + (ClientData) 123); + Tcl_CreateMathFunc(interp, "T2", 0, (Tcl_ValueType *) NULL, TestMathFunc, + (ClientData) 345); + + /* + * Specify a user-specific startup file to invoke if the application + * is run interactively. If this line is deleted then no user-specific + * startup file will be run under any conditions. + */ + + tcl_RcFileName = "~/.tclshrc"; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TestasyncCmd -- + * + * This procedure implements the "testasync" command. It is used + * to test the asynchronous handler facilities of Tcl. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Creates, deletes, and invokes handlers. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +TestasyncCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + TestAsyncHandler *asyncPtr, *prevPtr; + int id, code; + static int nextId = 1; + + if (argc < 2) { + wrongNumArgs: + interp->result = "wrong # args"; + return TCL_ERROR; + } + if (strcmp(argv[1], "create") == 0) { + if (argc != 3) { + goto wrongNumArgs; + } + asyncPtr = (TestAsyncHandler *) ckalloc(sizeof(TestAsyncHandler)); + asyncPtr->id = nextId; + nextId++; + asyncPtr->handler = Tcl_AsyncCreate(AsyncHandlerProc, + (ClientData) asyncPtr); + asyncPtr->command = ckalloc((unsigned) (strlen(argv[2]) + 1)); + strcpy(asyncPtr->command, argv[2]); + asyncPtr->nextPtr = firstHandler; + firstHandler = asyncPtr; + sprintf(interp->result, "%d", asyncPtr->id); + } else if (strcmp(argv[1], "delete") == 0) { + if (argc == 2) { + while (firstHandler != NULL) { + asyncPtr = firstHandler; + firstHandler = asyncPtr->nextPtr; + Tcl_AsyncDelete(asyncPtr->handler); + ckfree(asyncPtr->command); + ckfree((char *) asyncPtr); + } + return TCL_OK; + } + if (argc != 3) { + goto wrongNumArgs; + } + if (Tcl_GetInt(interp, argv[2], &id) != TCL_OK) { + return TCL_ERROR; + } + for (prevPtr = NULL, asyncPtr = firstHandler; asyncPtr != NULL; + prevPtr = asyncPtr, asyncPtr = asyncPtr->nextPtr) { + if (asyncPtr->id != id) { + continue; + } + if (prevPtr == NULL) { + firstHandler = asyncPtr->nextPtr; + } else { + prevPtr->nextPtr = asyncPtr->nextPtr; + } + Tcl_AsyncDelete(asyncPtr->handler); + ckfree(asyncPtr->command); + ckfree((char *) asyncPtr); + break; + } + } else if (strcmp(argv[1], "int") == 0) { + if (argc != 2) { + goto wrongNumArgs; + } + intHandler = Tcl_AsyncCreate(IntHandlerProc, (ClientData) interp); + signal(SIGINT, IntProc); + } else if (strcmp(argv[1], "mark") == 0) { + if (argc != 5) { + goto wrongNumArgs; + } + if ((Tcl_GetInt(interp, argv[2], &id) != TCL_OK) + || (Tcl_GetInt(interp, argv[4], &code) != TCL_OK)) { + return TCL_ERROR; + } + for (asyncPtr = firstHandler; asyncPtr != NULL; + asyncPtr = asyncPtr->nextPtr) { + if (asyncPtr->id == id) { + Tcl_AsyncMark(asyncPtr->handler); + break; + } + } + Tcl_SetResult(interp, argv[3], TCL_VOLATILE); + return code; + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": must be create, delete, int, or mark", + (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +static int +AsyncHandlerProc(clientData, interp, code) + ClientData clientData; /* Pointer to TestAsyncHandler structure. */ + Tcl_Interp *interp; /* Interpreter in which command was + * executed, or NULL. */ + int code; /* Current return code from command. */ +{ + TestAsyncHandler *asyncPtr = (TestAsyncHandler *) clientData; + char *listArgv[4]; + char string[20], *cmd; + + sprintf(string, "%d", code); + listArgv[0] = asyncPtr->command; + listArgv[1] = interp->result; + listArgv[2] = string; + listArgv[3] = NULL; + cmd = Tcl_Merge(3, listArgv); + code = Tcl_Eval(interp, cmd); + ckfree(cmd); + return code; +} + +static void +IntProc() +{ + Tcl_AsyncMark(intHandler); +} + +static int +IntHandlerProc(clientData, interp, code) + ClientData clientData; /* Interpreter in which to invoke command. */ + Tcl_Interp *interp; /* Interpreter in which command was + * executed, or NULL. */ + int code; /* Current return code from command. */ +{ + char *listArgv[4]; + char string[20], *cmd; + + interp = (Tcl_Interp *) clientData; + listArgv[0] = Tcl_GetVar(interp, "sigIntCmd", TCL_GLOBAL_ONLY); + if (listArgv[0] == NULL) { + return code; + } + listArgv[1] = interp->result; + sprintf(string, "%d", code); + listArgv[2] = string; + listArgv[3] = NULL; + cmd = Tcl_Merge(3, listArgv); + code = Tcl_Eval(interp, cmd); + ckfree(cmd); + return code; +} + +/* + *---------------------------------------------------------------------- + * + * TestdcallCmd -- + * + * This procedure implements the "testdcall" command. It is used + * to test Tcl_CallWhenDeleted. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Creates and deletes interpreters. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +TestdcallCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int i, id; + + delInterp = Tcl_CreateInterp(); + Tcl_DStringInit(&delString); + for (i = 1; i < argc; i++) { + if (Tcl_GetInt(interp, argv[i], &id) != TCL_OK) { + return TCL_ERROR; + } + if (id < 0) { + Tcl_DontCallWhenDeleted(delInterp, DelCallbackProc, + (ClientData) (-id)); + } else { + Tcl_CallWhenDeleted(delInterp, DelCallbackProc, + (ClientData) id); + } + } + Tcl_DeleteInterp(delInterp); + Tcl_DStringResult(interp, &delString); + return TCL_OK; +} + +/* + * The deletion callback used by TestdcallCmd: + */ + +static void +DelCallbackProc(clientData, interp) + ClientData clientData; /* Numerical value to append to + * delString. */ + Tcl_Interp *interp; /* Interpreter being deleted. */ +{ + int id = (int) clientData; + char buffer[10]; + + sprintf(buffer, "%d", id); + Tcl_DStringAppendElement(&delString, buffer); + if (interp != delInterp) { + Tcl_DStringAppendElement(&delString, "bogus interpreter argument!"); + } +} + +/* + *---------------------------------------------------------------------- + * + * TestcmdinfoCmd -- + * + * This procedure implements the "testcmdinfo" command. It is used + * to test Tcl_GetCmdInfo, Tcl_SetCmdInfo, and command creation + * and deletion. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Creates and deletes various commands and modifies their data. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +TestcmdinfoCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Tcl_CmdInfo info; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " option cmdName\"", (char *) NULL); + return TCL_ERROR; + } + if (strcmp(argv[1], "create") == 0) { + Tcl_CreateCommand(interp, argv[2], CmdProc1, (ClientData) "original", + CmdDelProc1); + } else if (strcmp(argv[1], "delete") == 0) { + Tcl_DStringInit(&delString); + Tcl_DeleteCommand(interp, argv[2]); + Tcl_DStringResult(interp, &delString); + } else if (strcmp(argv[1], "get") == 0) { + if (Tcl_GetCommandInfo(interp, argv[2], &info) ==0) { + interp->result = "??"; + return TCL_OK; + } + if (info.proc == CmdProc1) { + Tcl_AppendResult(interp, "CmdProc1", " ", + (char *) info.clientData, (char *) NULL); + } else if (info.proc == CmdProc2) { + Tcl_AppendResult(interp, "CmdProc2", " ", + (char *) info.clientData, (char *) NULL); + } else { + Tcl_AppendResult(interp, "unknown", (char *) NULL); + } + if (info.deleteProc == CmdDelProc1) { + Tcl_AppendResult(interp, " CmdDelProc1", " ", + (char *) info.deleteData, (char *) NULL); + } else if (info.deleteProc == CmdDelProc2) { + Tcl_AppendResult(interp, " CmdDelProc2", " ", + (char *) info.deleteData, (char *) NULL); + } else { + Tcl_AppendResult(interp, " unknown", (char *) NULL); + } + } else if (strcmp(argv[1], "modify") == 0) { + info.proc = CmdProc2; + info.clientData = (ClientData) "new_command_data"; + info.deleteProc = CmdDelProc2; + info.deleteData = (ClientData) "new_delete_data"; + if (Tcl_SetCommandInfo(interp, argv[2], &info) == 0) { + interp->result = "0"; + } else { + interp->result = "1"; + } + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": must be create, delete, get, or modify", + (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + + /*ARGSUSED*/ +static int +CmdProc1(clientData, interp, argc, argv) + ClientData clientData; /* String to return. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Tcl_AppendResult(interp, "CmdProc1 ", (char *) clientData, + (char *) NULL); + return TCL_OK; +} + + /*ARGSUSED*/ +static int +CmdProc2(clientData, interp, argc, argv) + ClientData clientData; /* String to return. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Tcl_AppendResult(interp, "CmdProc2 ", (char *) clientData, + (char *) NULL); + return TCL_OK; +} + +static void +CmdDelProc1(clientData) + ClientData clientData; /* String to save. */ +{ + Tcl_DStringInit(&delString); + Tcl_DStringAppend(&delString, "CmdDelProc1 ", -1); + Tcl_DStringAppend(&delString, (char *) clientData, -1); +} + +static void +CmdDelProc2(clientData) + ClientData clientData; /* String to save. */ +{ + Tcl_DStringInit(&delString); + Tcl_DStringAppend(&delString, "CmdDelProc2 ", -1); + Tcl_DStringAppend(&delString, (char *) clientData, -1); +} + +/* + *---------------------------------------------------------------------- + * + * TestdstringCmd -- + * + * This procedure implements the "testdstring" command. It is used + * to test the dynamic string facilities of Tcl. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Creates, deletes, and invokes handlers. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +TestdstringCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int count; + + if (argc < 2) { + wrongNumArgs: + interp->result = "wrong # args"; + return TCL_ERROR; + } + if (strcmp(argv[1], "append") == 0) { + if (argc != 4) { + goto wrongNumArgs; + } + if (Tcl_GetInt(interp, argv[3], &count) != TCL_OK) { + return TCL_ERROR; + } + Tcl_DStringAppend(&dstring, argv[2], count); + } else if (strcmp(argv[1], "element") == 0) { + if (argc != 3) { + goto wrongNumArgs; + } + Tcl_DStringAppendElement(&dstring, argv[2]); + } else if (strcmp(argv[1], "end") == 0) { + if (argc != 2) { + goto wrongNumArgs; + } + Tcl_DStringEndSublist(&dstring); + } else if (strcmp(argv[1], "free") == 0) { + if (argc != 2) { + goto wrongNumArgs; + } + Tcl_DStringFree(&dstring); + } else if (strcmp(argv[1], "get") == 0) { + if (argc != 2) { + goto wrongNumArgs; + } + interp->result = Tcl_DStringValue(&dstring); + } else if (strcmp(argv[1], "length") == 0) { + if (argc != 2) { + goto wrongNumArgs; + } + sprintf(interp->result, "%d", Tcl_DStringLength(&dstring)); + } else if (strcmp(argv[1], "result") == 0) { + if (argc != 2) { + goto wrongNumArgs; + } + Tcl_DStringResult(interp, &dstring); + } else if (strcmp(argv[1], "trunc") == 0) { + if (argc != 3) { + goto wrongNumArgs; + } + if (Tcl_GetInt(interp, argv[2], &count) != TCL_OK) { + return TCL_ERROR; + } + Tcl_DStringTrunc(&dstring, count); + } else if (strcmp(argv[1], "start") == 0) { + if (argc != 2) { + goto wrongNumArgs; + } + Tcl_DStringStartSublist(&dstring); + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": must be append, element, end, free, get, length, ", + "result, trunc, or start", (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TestlinkCmd -- + * + * This procedure implements the "testlink" command. It is used + * to test Tcl_LinkVar and related library procedures. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Creates and deletes various variable links, plus returns + * values of the linked variables. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +TestlinkCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + static int intVar = 43; + static int boolVar = 4; + static double realVar = 1.23; + static char *stringVar = NULL; + char buffer[TCL_DOUBLE_SPACE]; + int writable, flag; + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " option ?arg arg arg?\"", (char *) NULL); + return TCL_ERROR; + } + if (strcmp(argv[1], "create") == 0) { + if (Tcl_GetBoolean(interp, argv[2], &writable) != TCL_OK) { + return TCL_ERROR; + } + flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; + if (Tcl_LinkVar(interp, "int", (char *) &intVar, + TCL_LINK_INT | flag) != TCL_OK) { + return TCL_ERROR; + } + if (Tcl_GetBoolean(interp, argv[3], &writable) != TCL_OK) { + return TCL_ERROR; + } + flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; + if (Tcl_LinkVar(interp, "real", (char *) &realVar, + TCL_LINK_DOUBLE | flag) != TCL_OK) { + return TCL_ERROR; + } + if (Tcl_GetBoolean(interp, argv[4], &writable) != TCL_OK) { + return TCL_ERROR; + } + flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; + if (Tcl_LinkVar(interp, "bool", (char *) &boolVar, + TCL_LINK_BOOLEAN | flag) != TCL_OK) { + return TCL_ERROR; + } + if (Tcl_GetBoolean(interp, argv[5], &writable) != TCL_OK) { + return TCL_ERROR; + } + flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; + if (Tcl_LinkVar(interp, "string", (char *) &stringVar, + TCL_LINK_STRING | flag) != TCL_OK) { + return TCL_ERROR; + } + } else if (strcmp(argv[1], "delete") == 0) { + Tcl_UnlinkVar(interp, "int"); + Tcl_UnlinkVar(interp, "real"); + Tcl_UnlinkVar(interp, "bool"); + Tcl_UnlinkVar(interp, "string"); + } else if (strcmp(argv[1], "get") == 0) { + sprintf(buffer, "%d", intVar); + Tcl_AppendElement(interp, buffer); + Tcl_PrintDouble(interp, realVar, buffer); + Tcl_AppendElement(interp, buffer); + sprintf(buffer, "%d", boolVar); + Tcl_AppendElement(interp, buffer); + Tcl_AppendElement(interp, (stringVar == NULL) ? "-" : stringVar); + } else if (strcmp(argv[1], "set") == 0) { + if (argc != 6) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " ", argv[1], + "intValue realValue boolValue stringValue\"", (char *) NULL); + return TCL_ERROR; + } + if (argv[2][0] != 0) { + if (Tcl_GetInt(interp, argv[2], &intVar) != TCL_OK) { + return TCL_ERROR; + } + } + if (argv[3][0] != 0) { + if (Tcl_GetDouble(interp, argv[3], &realVar) != TCL_OK) { + return TCL_ERROR; + } + } + if (argv[4][0] != 0) { + if (Tcl_GetInt(interp, argv[4], &boolVar) != TCL_OK) { + return TCL_ERROR; + } + } + if (argv[5][0] != 0) { + if (stringVar != NULL) { + ckfree(stringVar); + } + if (strcmp(argv[5], "-") == 0) { + stringVar = NULL; + } else { + stringVar = ckalloc((unsigned) (strlen(argv[5]) + 1)); + strcpy(stringVar, argv[5]); + } + } + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": should be create, delete, get, or set", + (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TestMathFunc -- + * + * This is a user-defined math procedure to test out math procedures + * with no arguments. + * + * Results: + * A normal Tcl completion code. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +TestMathFunc(clientData, interp, args, resultPtr) + ClientData clientData; /* Integer value to return. */ + Tcl_Interp *interp; /* Not used. */ + Tcl_Value *args; /* Not used. */ + Tcl_Value *resultPtr; /* Where to store result. */ +{ + resultPtr->type = TCL_INT; + resultPtr->intValue = (int) clientData; + return TCL_OK; +} diff --git a/vendor/x11iraf/obm/Tcl/tclUnix.h b/vendor/x11iraf/obm/Tcl/tclUnix.h new file mode 100644 index 00000000..343b0253 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/tclUnix.h @@ -0,0 +1,285 @@ +/* + * tclUnix.h -- + * + * This file reads in UNIX-related header files and sets up + * UNIX-related macros for Tcl's UNIX core. It should be the + * only file that contains #ifdefs to handle different flavors + * of UNIX. This file sets up the union of all UNIX-related + * things needed by any of the Tcl core files. This file + * depends on configuration #defines in tclConfig.h + * + * Much of the material in this file was originally contributed + * by Karl Lehenbauer, Mark Diekhans and Peter da Silva. + * + * Copyright (c) 1991-1993 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. + * + * $Header: /user6/ouster/tcl/RCS/tclUnix.h,v 1.46 93/10/28 16:32:28 ouster Exp $ SPRITE (Berkeley) + */ + +#ifndef _TCLUNIX +#define _TCLUNIX + +#include <errno.h> +#include <fcntl.h> +#include <pwd.h> +#include <signal.h> +#include <sys/param.h> +#include <sys/types.h> +#ifdef USE_DIRENT2_H +# include "compat/dirent2.h" +#else +# ifdef NO_DIRENT_H +# include "compat/dirent.h" +# else +# include <dirent.h> +# endif +#endif +#include <sys/file.h> +#include <sys/stat.h> +#ifndef NO_SYS_TIME_H +# include <sys/time.h> +#else +# include <time.h> +#endif +#ifndef NO_SYS_WAIT_H +# include <sys/wait.h> +#endif +#ifdef HAVE_UNISTD_H +# include <unistd.h> +#else +# include "compat/unistd.h" +#endif + +/* + * Not all systems declare the errno variable in errno.h. so this + * file does it explicitly. The list of system error messages also + * isn't generally declared in a header file anywhere. + */ + +extern int errno; + +/* + * The type of the status returned by wait varies from UNIX system + * to UNIX system. The macro below defines it: + */ + +#ifdef AIX +# define WAIT_STATUS_TYPE pid_t +#else +#ifndef NO_UNION_WAIT +# define WAIT_STATUS_TYPE union wait +#else +# define WAIT_STATUS_TYPE int +#endif +#endif + +/* + * Supply definitions for macros to query wait status, if not already + * defined in header files above. + */ + +#ifndef WIFEXITED +# define WIFEXITED(stat) (((*((int *) &(stat))) & 0xff) == 0) +#endif + +#ifndef WEXITSTATUS +# define WEXITSTATUS(stat) (((*((int *) &(stat))) >> 8) & 0xff) +#endif + +#ifndef WIFSIGNALED +# define WIFSIGNALED(stat) (((*((int *) &(stat)))) && ((*((int *) &(stat))) == ((*((int *) &(stat))) & 0x00ff))) +#endif + +#ifndef WTERMSIG +# define WTERMSIG(stat) ((*((int *) &(stat))) & 0x7f) +#endif + +#ifndef WIFSTOPPED +# define WIFSTOPPED(stat) (((*((int *) &(stat))) & 0xff) == 0177) +#endif + +#ifndef WSTOPSIG +# define WSTOPSIG(stat) (((*((int *) &(stat))) >> 8) & 0xff) +#endif + +/* + * Supply macros for seek offsets, if they're not already provided by + * an include file. + */ + +#ifndef SEEK_SET +# define SEEK_SET 0 +#endif + +#ifndef SEEK_CUR +# define SEEK_CUR 1 +#endif + +#ifndef SEEK_END +# define SEEK_END 2 +#endif + +/* + * The stuff below is needed by the "time" command. If this + * system has no gettimeofday call, then must use times and the + * CLK_TCK #define (from sys/param.h) to compute elapsed time. + * Unfortunately, some systems only have HZ and no CLK_TCK, and + * some might not even have HZ. + */ + +#ifdef NO_GETTOD +# include <sys/times.h> +# include <sys/param.h> +# ifndef CLK_TCK +# ifdef HZ +# define CLK_TCK HZ +# else +# define CLK_TCK 60 +# endif +# endif +#endif + +/* + * Define access mode constants if they aren't already defined. + */ + +#ifndef F_OK +# define F_OK 00 +#endif +#ifndef X_OK +# define X_OK 01 +#endif +#ifndef W_OK +# define W_OK 02 +#endif +#ifndef R_OK +# define R_OK 04 +#endif + +/* + * On systems without symbolic links (i.e. S_IFLNK isn't defined) + * define "lstat" to use "stat" instead. + */ + +#ifndef S_IFLNK +# define lstat stat +#endif + +/* + * Define macros to query file type bits, if they're not already + * defined. + */ + +#ifndef S_ISREG +# ifdef S_IFREG +# define S_ISREG(m) (((m) & S_IFMT) == S_IFREG) +# else +# define S_ISREG(m) 0 +# endif +# endif +#ifndef S_ISDIR +# ifdef S_IFDIR +# define S_ISDIR(m) (((m) & S_IFMT) == S_IFDIR) +# else +# define S_ISDIR(m) 0 +# endif +# endif +#ifndef S_ISCHR +# ifdef S_IFCHR +# define S_ISCHR(m) (((m) & S_IFMT) == S_IFCHR) +# else +# define S_ISCHR(m) 0 +# endif +# endif +#ifndef S_ISBLK +# ifdef S_IFBLK +# define S_ISBLK(m) (((m) & S_IFMT) == S_IFBLK) +# else +# define S_ISBLK(m) 0 +# endif +# endif +#ifndef S_ISFIFO +# ifdef S_IFIFO +# define S_ISFIFO(m) (((m) & S_IFMT) == S_IFIFO) +# else +# define S_ISFIFO(m) 0 +# endif +# endif +#ifndef S_ISLNK +# ifdef S_IFLNK +# define S_ISLNK(m) (((m) & S_IFMT) == S_IFLNK) +# else +# define S_ISLNK(m) 0 +# endif +# endif +#ifndef S_ISSOCK +# ifdef S_IFSOCK +# define S_ISSOCK(m) (((m) & S_IFMT) == S_IFSOCK) +# else +# define S_ISSOCK(m) 0 +# endif +# endif + +/* + * Make sure that MAXPATHLEN is defined. + */ + +#ifndef MAXPATHLEN +# ifdef PATH_MAX +# define MAXPATHLEN PATH_MAX +# else +# define MAXPATHLEN 2048 +# endif +#endif + +/* + * Make sure that L_tmpnam is defined. + */ + +#ifndef L_tmpnam +# define L_tmpnam 100 +#endif + +/* + * Substitute Tcl's own versions for several system calls. The + * Tcl versions retry automatically if interrupted by signals. + * (see tclUnixUtil.c). + */ + +#define open(a,b,c) TclOpen(a,b,c) +#define read(a,b,c) TclRead(a,b,c) +#define waitpid(a,b,c) TclWaitpid(a,b,c) +#define write(a,b,c) TclWrite(a,b,c) +EXTERN int TclOpen _ANSI_ARGS_((char *path, int oflag, int mode)); +EXTERN int TclRead _ANSI_ARGS_((int fd, VOID *buf, size_t numBytes)); +EXTERN int TclWaitpid _ANSI_ARGS_((pid_t pid, int *statPtr, int options)); +EXTERN int TclWrite _ANSI_ARGS_((int fd, VOID *buf, size_t numBytes)); + +/* + * Variables provided by the C library: + */ + +#if defined(_sgi) || defined(__sgi) +#define environ _environ +#endif +extern char **environ; + +#endif /* _TCLUNIX */ diff --git a/vendor/x11iraf/obm/Tcl/tclUnixAZ.c b/vendor/x11iraf/obm/Tcl/tclUnixAZ.c new file mode 100644 index 00000000..765b7f03 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/tclUnixAZ.c @@ -0,0 +1,1998 @@ +/* + * tclUnixAZ.c -- + * + * This file contains the top-level command procedures for + * commands in the Tcl core that require UNIX facilities + * such as files and process execution. Much of the code + * in this file is based on earlier versions contributed + * by Karl Lehenbauer, Mark Diekhans and Peter da Silva. + * + * Copyright (c) 1991-1993 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. + */ + +#ifndef lint +static char rcsid[] = "$Header: /user6/ouster/tcl/RCS/tclUnixAZ.c,v 1.70 93/09/24 16:47:39 ouster Exp $ SPRITE (Berkeley)"; +#endif /* not lint */ + +#include "tclInt.h" +#include "tclUnix.h" + +/* + * The variable below caches the name of the current working directory + * in order to avoid repeated calls to getcwd. The string is malloc-ed. + * NULL means the cache needs to be refreshed. + */ + +static char *currentDir = NULL; + +/* + * If the system doesn't define the EWOULDBLOCK errno, just #define it + * to a bogus value that will never occur. + */ + +#ifndef EWOULDBLOCK +#define EWOULDBLOCK -1901 +#endif + +/* + * Prototypes for local procedures defined in this file: + */ + +static int CleanupChildren _ANSI_ARGS_((Tcl_Interp *interp, + int numPids, int *pidPtr, int errorId, + int keepNewline)); +static char * GetFileType _ANSI_ARGS_((int mode)); +static char * GetOpenMode _ANSI_ARGS_((Tcl_Interp *interp, + char *string, int *modePtr)); +static int StoreStatData _ANSI_ARGS_((Tcl_Interp *interp, + char *varName, struct stat *statPtr)); + +/* + *---------------------------------------------------------------------- + * + * Tcl_CdCmd -- + * + * This procedure is invoked to process the "cd" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_CdCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + char *dirName; + Tcl_DString buffer; + int result; + + if (argc > 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " dirName\"", (char *) NULL); + return TCL_ERROR; + } + + if (argc == 2) { + dirName = argv[1]; + } else { + dirName = "~"; + } + dirName = Tcl_TildeSubst(interp, dirName, &buffer); + if (dirName == NULL) { + return TCL_ERROR; + } + if (currentDir != NULL) { + ckfree(currentDir); + currentDir = NULL; + } + result = TCL_OK; + if (chdir(dirName) != 0) { + Tcl_AppendResult(interp, "couldn't change working directory to \"", + dirName, "\": ", Tcl_PosixError(interp), (char *) NULL); + result = TCL_ERROR; + } + Tcl_DStringFree(&buffer); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_CloseCmd -- + * + * This procedure is invoked to process the "close" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_CloseCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + OpenFile *oFilePtr; + int result = TCL_OK; + FILE *f; + + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " fileId\"", (char *) NULL); + return TCL_ERROR; + } + if (Tcl_GetOpenFile(interp, argv[1], 0, 0, &f) != TCL_OK) { + return TCL_ERROR; + } + oFilePtr = tclOpenFiles[fileno(f)]; + tclOpenFiles[fileno(f)] = NULL; + + /* + * First close the file (in the case of a process pipeline, there may + * be two files, one for the pipe at each end of the pipeline). + */ + + if (oFilePtr->f2 != NULL) { + clearerr(oFilePtr->f2); + if (fclose(oFilePtr->f2) == EOF) { + Tcl_AppendResult(interp, "error closing \"", argv[1], + "\": ", Tcl_PosixError(interp), "\n", (char *) NULL); + result = TCL_ERROR; + } + } + clearerr(oFilePtr->f); + if (fclose(oFilePtr->f) == EOF) { + Tcl_AppendResult(interp, "error closing \"", argv[1], + "\": ", Tcl_PosixError(interp), "\n", (char *) NULL); + result = TCL_ERROR; + } + + /* + * If the file was a connection to a pipeline, clean up everything + * associated with the child processes. + */ + + if (oFilePtr->numPids > 0) { + if (CleanupChildren(interp, oFilePtr->numPids, oFilePtr->pidPtr, + oFilePtr->errorId, 0) != TCL_OK) { + result = TCL_ERROR; + } + } + + ckfree((char *) oFilePtr); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_EofCmd -- + * + * This procedure is invoked to process the "eof" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_EofCmd(notUsed, interp, argc, argv) + ClientData notUsed; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + FILE *f; + + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " fileId\"", (char *) NULL); + return TCL_ERROR; + } + if (Tcl_GetOpenFile(interp, argv[1], 0, 0, &f) != TCL_OK) { + return TCL_ERROR; + } + if (feof(f)) { + interp->result = "1"; + } else { + interp->result = "0"; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ExecCmd -- + * + * This procedure is invoked to process the "exec" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_ExecCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int outputId; /* File id for output pipe. -1 + * means command overrode. */ + int errorId; /* File id for temporary file + * containing error output. */ + int *pidPtr; + int numPids, result, keepNewline; + int firstWord; + + /* + * Check for a leading "-keepnewline" argument. + */ + + keepNewline = 0; + for (firstWord = 1; (firstWord < argc) && (argv[firstWord][0] == '-'); + firstWord++) { + if (strcmp(argv[firstWord], "-keepnewline") == 0) { + keepNewline = 1; + } else if (strcmp(argv[firstWord], "--") == 0) { + firstWord++; + break; + } else { + Tcl_AppendResult(interp, "bad switch \"", argv[firstWord], + "\": must be -keepnewline or --", (char *) NULL); + return TCL_ERROR; + } + } + + if (argc <= firstWord) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " ?switches? arg ?arg ...?\"", (char *) NULL); + return TCL_ERROR; + } + + /* + * See if the command is to be run in background; if so, create + * the command, detach it, and return a list of pids. + */ + + if ((argv[argc-1][0] == '&') && (argv[argc-1][1] == 0)) { + int i; + char id[50]; + + argc--; + argv[argc] = NULL; + numPids = Tcl_CreatePipeline(interp, argc-firstWord, argv+firstWord, + &pidPtr, (int *) NULL, (int *) NULL, (int *) NULL); + if (numPids < 0) { + return TCL_ERROR; + } + Tcl_DetachPids(numPids, pidPtr); + for (i = 0; i < numPids; i++) { + sprintf(id, "%d", pidPtr[i]); + Tcl_AppendElement(interp, id); + } + ckfree((char *) pidPtr); + return TCL_OK; + } + + /* + * Create the command's pipeline. + */ + + numPids = Tcl_CreatePipeline(interp, argc-firstWord, argv+firstWord, + &pidPtr, (int *) NULL, &outputId, &errorId); + if (numPids < 0) { + return TCL_ERROR; + } + + /* + * Read the child's output (if any) and put it into the result. + */ + + result = TCL_OK; + if (outputId != -1) { + while (1) { +# define BUFFER_SIZE 1000 + char buffer[BUFFER_SIZE+1]; + int count; + + count = read(outputId, buffer, (size_t) BUFFER_SIZE); + + if (count == 0) { + break; + } + if (count < 0) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, + "error reading from output pipe: ", + Tcl_PosixError(interp), (char *) NULL); + result = TCL_ERROR; + break; + } + buffer[count] = 0; + Tcl_AppendResult(interp, buffer, (char *) NULL); + } + close(outputId); + } + + if (CleanupChildren(interp, numPids, pidPtr, errorId, keepNewline) + != TCL_OK) { + result = TCL_ERROR; + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ExitCmd -- + * + * This procedure is invoked to process the "exit" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_ExitCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int value; + + if ((argc != 1) && (argc != 2)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " ?returnCode?\"", (char *) NULL); + return TCL_ERROR; + } + if (argc == 1) { + exit(0); + } + if (Tcl_GetInt(interp, argv[1], &value) != TCL_OK) { + return TCL_ERROR; + } + exit(value); + /*NOTREACHED*/ + return TCL_OK; /* Better not ever reach this! */ +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_FileCmd -- + * + * This procedure is invoked to process the "file" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_FileCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + char *p; + int length, statOp, result; + int mode = 0; /* Initialized only to prevent + * compiler warning message. */ + struct stat statBuf; + char *fileName, c; + Tcl_DString buffer; + + if (argc < 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " option name ?arg ...?\"", (char *) NULL); + return TCL_ERROR; + } + c = argv[1][0]; + length = strlen(argv[1]); + result = TCL_OK; + + /* + * First handle operations on the file name. + */ + + fileName = Tcl_TildeSubst(interp, argv[2], &buffer); + if (fileName == NULL) { + result = TCL_ERROR; + goto done; + } + if ((c == 'd') && (strncmp(argv[1], "dirname", length) == 0)) { + if (argc != 3) { + argv[1] = "dirname"; + not3Args: + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " ", argv[1], " name\"", (char *) NULL); + result = TCL_ERROR; + goto done; + } + p = strrchr(fileName, '/'); + if (p == NULL) { + interp->result = "."; + } else if (p == fileName) { + interp->result = "/"; + } else { + *p = 0; + Tcl_SetResult(interp, fileName, TCL_VOLATILE); + *p = '/'; + } + goto done; + } else if ((c == 'r') && (strncmp(argv[1], "rootname", length) == 0) + && (length >= 2)) { + char *lastSlash; + + if (argc != 3) { + argv[1] = "rootname"; + goto not3Args; + } + p = strrchr(fileName, '.'); + lastSlash = strrchr(fileName, '/'); + if ((p == NULL) || ((lastSlash != NULL) && (lastSlash > p))) { + Tcl_SetResult(interp, fileName, TCL_VOLATILE); + } else { + *p = 0; + Tcl_SetResult(interp, fileName, TCL_VOLATILE); + *p = '.'; + } + goto done; + } else if ((c == 'e') && (strncmp(argv[1], "extension", length) == 0) + && (length >= 3)) { + char *lastSlash; + + if (argc != 3) { + argv[1] = "extension"; + goto not3Args; + } + p = strrchr(fileName, '.'); + lastSlash = strrchr(fileName, '/'); + if ((p != NULL) && ((lastSlash == NULL) || (lastSlash < p))) { + Tcl_SetResult(interp, p, TCL_VOLATILE); + } + goto done; + } else if ((c == 't') && (strncmp(argv[1], "tail", length) == 0) + && (length >= 2)) { + if (argc != 3) { + argv[1] = "tail"; + goto not3Args; + } + p = strrchr(fileName, '/'); + if (p != NULL) { + Tcl_SetResult(interp, p+1, TCL_VOLATILE); + } else { + Tcl_SetResult(interp, fileName, TCL_VOLATILE); + } + goto done; + } + + /* + * Next, handle operations that can be satisfied with the "access" + * kernel call. + */ + + if (fileName == NULL) { + result = TCL_ERROR; + goto done; + } + if ((c == 'r') && (strncmp(argv[1], "readable", length) == 0) + && (length >= 5)) { + if (argc != 3) { + argv[1] = "readable"; + goto not3Args; + } + mode = R_OK; + checkAccess: + if (access(fileName, mode) == -1) { + interp->result = "0"; + } else { + interp->result = "1"; + } + goto done; + } else if ((c == 'w') && (strncmp(argv[1], "writable", length) == 0)) { + if (argc != 3) { + argv[1] = "writable"; + goto not3Args; + } + mode = W_OK; + goto checkAccess; + } else if ((c == 'e') && (strncmp(argv[1], "executable", length) == 0) + && (length >= 3)) { + if (argc != 3) { + argv[1] = "executable"; + goto not3Args; + } + mode = X_OK; + goto checkAccess; + } else if ((c == 'e') && (strncmp(argv[1], "exists", length) == 0) + && (length >= 3)) { + if (argc != 3) { + argv[1] = "exists"; + goto not3Args; + } + mode = F_OK; + goto checkAccess; + } + + /* + * Lastly, check stuff that requires the file to be stat-ed. + */ + + if ((c == 'a') && (strncmp(argv[1], "atime", length) == 0)) { + if (argc != 3) { + argv[1] = "atime"; + goto not3Args; + } + if (stat(fileName, &statBuf) == -1) { + goto badStat; + } + sprintf(interp->result, "%ld", statBuf.st_atime); + goto done; + } else if ((c == 'i') && (strncmp(argv[1], "isdirectory", length) == 0) + && (length >= 3)) { + if (argc != 3) { + argv[1] = "isdirectory"; + goto not3Args; + } + statOp = 2; + } else if ((c == 'i') && (strncmp(argv[1], "isfile", length) == 0) + && (length >= 3)) { + if (argc != 3) { + argv[1] = "isfile"; + goto not3Args; + } + statOp = 1; + } else if ((c == 'l') && (strncmp(argv[1], "lstat", length) == 0)) { + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " lstat name varName\"", (char *) NULL); + result = TCL_ERROR; + goto done; + } + + if (lstat(fileName, &statBuf) == -1) { + Tcl_AppendResult(interp, "couldn't lstat \"", argv[2], + "\": ", Tcl_PosixError(interp), (char *) NULL); + result = TCL_ERROR; + goto done; + } + result = StoreStatData(interp, argv[3], &statBuf); + goto done; + } else if ((c == 'm') && (strncmp(argv[1], "mtime", length) == 0)) { + if (argc != 3) { + argv[1] = "mtime"; + goto not3Args; + } + if (stat(fileName, &statBuf) == -1) { + goto badStat; + } + sprintf(interp->result, "%ld", statBuf.st_mtime); + goto done; + } else if ((c == 'o') && (strncmp(argv[1], "owned", length) == 0)) { + if (argc != 3) { + argv[1] = "owned"; + goto not3Args; + } + statOp = 0; + } else if ((c == 'r') && (strncmp(argv[1], "readlink", length) == 0) + && (length >= 5)) { + char linkValue[MAXPATHLEN+1]; + int linkLength; + + if (argc != 3) { + argv[1] = "readlink"; + goto not3Args; + } + + /* + * If S_IFLNK isn't defined it means that the machine doesn't + * support symbolic links, so the file can't possibly be a + * symbolic link. Generate an EINVAL error, which is what + * happens on machines that do support symbolic links when + * you invoke readlink on a file that isn't a symbolic link. + */ + +#ifndef S_IFLNK + linkLength = -1; + errno = EINVAL; +#else + linkLength = readlink(fileName, linkValue, sizeof(linkValue) - 1); +#endif /* S_IFLNK */ + if (linkLength == -1) { + Tcl_AppendResult(interp, "couldn't readlink \"", argv[2], + "\": ", Tcl_PosixError(interp), (char *) NULL); + result = TCL_ERROR; + goto done; + } + linkValue[linkLength] = 0; + Tcl_SetResult(interp, linkValue, TCL_VOLATILE); + goto done; + } else if ((c == 's') && (strncmp(argv[1], "size", length) == 0) + && (length >= 2)) { + if (argc != 3) { + argv[1] = "size"; + goto not3Args; + } + if (stat(fileName, &statBuf) == -1) { + goto badStat; + } + sprintf(interp->result, "%ld", statBuf.st_size); + goto done; + } else if ((c == 's') && (strncmp(argv[1], "stat", length) == 0) + && (length >= 2)) { + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " stat name varName\"", (char *) NULL); + result = TCL_ERROR; + goto done; + } + + if (stat(fileName, &statBuf) == -1) { + badStat: + Tcl_AppendResult(interp, "couldn't stat \"", argv[2], + "\": ", Tcl_PosixError(interp), (char *) NULL); + result = TCL_ERROR; + goto done; + } + result = StoreStatData(interp, argv[3], &statBuf); + goto done; + } else if ((c == 't') && (strncmp(argv[1], "type", length) == 0) + && (length >= 2)) { + if (argc != 3) { + argv[1] = "type"; + goto not3Args; + } + if (lstat(fileName, &statBuf) == -1) { + goto badStat; + } + interp->result = GetFileType((int) statBuf.st_mode); + goto done; + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": should be atime, dirname, executable, exists, ", + "extension, isdirectory, isfile, lstat, mtime, owned, ", + "readable, readlink, ", + "root, size, stat, tail, type, ", + "or writable", + (char *) NULL); + result = TCL_ERROR; + goto done; + } + if (stat(fileName, &statBuf) == -1) { + interp->result = "0"; + goto done; + } + switch (statOp) { + case 0: + mode = (geteuid() == statBuf.st_uid); + break; + case 1: + mode = S_ISREG(statBuf.st_mode); + break; + case 2: + mode = S_ISDIR(statBuf.st_mode); + break; + } + if (mode) { + interp->result = "1"; + } else { + interp->result = "0"; + } + + done: + Tcl_DStringFree(&buffer); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * StoreStatData -- + * + * This is a utility procedure that breaks out the fields of a + * "stat" structure and stores them in textual form into the + * elements of an associative array. + * + * Results: + * Returns a standard Tcl return value. If an error occurs then + * a message is left in interp->result. + * + * Side effects: + * Elements of the associative array given by "varName" are modified. + * + *---------------------------------------------------------------------- + */ + +static int +StoreStatData(interp, varName, statPtr) + Tcl_Interp *interp; /* Interpreter for error reports. */ + char *varName; /* Name of associative array variable + * in which to store stat results. */ + struct stat *statPtr; /* Pointer to buffer containing + * stat data to store in varName. */ +{ + char string[30]; + + sprintf(string, "%d", statPtr->st_dev); + if (Tcl_SetVar2(interp, varName, "dev", string, TCL_LEAVE_ERR_MSG) + == NULL) { + return TCL_ERROR; + } + sprintf(string, "%d", statPtr->st_ino); + if (Tcl_SetVar2(interp, varName, "ino", string, TCL_LEAVE_ERR_MSG) + == NULL) { + return TCL_ERROR; + } + sprintf(string, "%d", statPtr->st_mode); + if (Tcl_SetVar2(interp, varName, "mode", string, TCL_LEAVE_ERR_MSG) + == NULL) { + return TCL_ERROR; + } + sprintf(string, "%d", statPtr->st_nlink); + if (Tcl_SetVar2(interp, varName, "nlink", string, TCL_LEAVE_ERR_MSG) + == NULL) { + return TCL_ERROR; + } + sprintf(string, "%d", statPtr->st_uid); + if (Tcl_SetVar2(interp, varName, "uid", string, TCL_LEAVE_ERR_MSG) + == NULL) { + return TCL_ERROR; + } + sprintf(string, "%d", statPtr->st_gid); + if (Tcl_SetVar2(interp, varName, "gid", string, TCL_LEAVE_ERR_MSG) + == NULL) { + return TCL_ERROR; + } + sprintf(string, "%ld", statPtr->st_size); + if (Tcl_SetVar2(interp, varName, "size", string, TCL_LEAVE_ERR_MSG) + == NULL) { + return TCL_ERROR; + } + sprintf(string, "%ld", statPtr->st_atime); + if (Tcl_SetVar2(interp, varName, "atime", string, TCL_LEAVE_ERR_MSG) + == NULL) { + return TCL_ERROR; + } + sprintf(string, "%ld", statPtr->st_mtime); + if (Tcl_SetVar2(interp, varName, "mtime", string, TCL_LEAVE_ERR_MSG) + == NULL) { + return TCL_ERROR; + } + sprintf(string, "%ld", statPtr->st_ctime); + if (Tcl_SetVar2(interp, varName, "ctime", string, TCL_LEAVE_ERR_MSG) + == NULL) { + return TCL_ERROR; + } + if (Tcl_SetVar2(interp, varName, "type", + GetFileType((int) statPtr->st_mode), TCL_LEAVE_ERR_MSG) == NULL) { + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * GetFileType -- + * + * Given a mode word, returns a string identifying the type of a + * file. + * + * Results: + * A static text string giving the file type from mode. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static char * +GetFileType(mode) + int mode; +{ + if (S_ISREG(mode)) { + return "file"; + } else if (S_ISDIR(mode)) { + return "directory"; + } else if (S_ISCHR(mode)) { + return "characterSpecial"; + } else if (S_ISBLK(mode)) { + return "blockSpecial"; + } else if (S_ISFIFO(mode)) { + return "fifo"; + } else if (S_ISLNK(mode)) { + return "link"; + } else if (S_ISSOCK(mode)) { + return "socket"; + } + return "unknown"; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_FlushCmd -- + * + * This procedure is invoked to process the "flush" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_FlushCmd(notUsed, interp, argc, argv) + ClientData notUsed; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + FILE *f; + + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " fileId\"", (char *) NULL); + return TCL_ERROR; + } + if (Tcl_GetOpenFile(interp, argv[1], 1, 1, &f) != TCL_OK) { + return TCL_ERROR; + } + clearerr(f); + if (fflush(f) == EOF) { + Tcl_AppendResult(interp, "error flushing \"", argv[1], + "\": ", Tcl_PosixError(interp), (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetsCmd -- + * + * This procedure is invoked to process the "gets" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_GetsCmd(notUsed, interp, argc, argv) + ClientData notUsed; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ +# define BUF_SIZE 200 + char buffer[BUF_SIZE+1]; + int totalCount, done, flags; + FILE *f; + + if ((argc != 2) && (argc != 3)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " fileId ?varName?\"", (char *) NULL); + return TCL_ERROR; + } + if (Tcl_GetOpenFile(interp, argv[1], 0, 1, &f) != TCL_OK) { + return TCL_ERROR; + } + + /* + * We can't predict how large a line will be, so read it in + * pieces, appending to the current result or to a variable. + */ + + totalCount = 0; + done = 0; + flags = 0; + clearerr(f); + while (!done) { + register int c, count; + register char *p; + + for (p = buffer, count = 0; count < BUF_SIZE-1; count++, p++) { + c = getc(f); + if (c == EOF) { + if (ferror(f)) { + /* + * If the file is in non-blocking mode, return any + * bytes that were read before a block would occur. + */ + + if ((errno == EWOULDBLOCK) + && ((count > 0 || totalCount > 0))) { + done = 1; + break; + } + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "error reading \"", argv[1], + "\": ", Tcl_PosixError(interp), (char *) NULL); + return TCL_ERROR; + } else if (feof(f)) { + if ((totalCount == 0) && (count == 0)) { + totalCount = -1; + } + done = 1; + break; + } + } + if (c == '\n') { + done = 1; + break; + } + *p = c; + } + *p = 0; + if (argc == 2) { + Tcl_AppendResult(interp, buffer, (char *) NULL); + } else { + if (Tcl_SetVar(interp, argv[2], buffer, flags|TCL_LEAVE_ERR_MSG) + == NULL) { + return TCL_ERROR; + } + flags = TCL_APPEND_VALUE; + } + totalCount += count; + } + + if (argc == 3) { + sprintf(interp->result, "%d", totalCount); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_OpenCmd -- + * + * This procedure is invoked to process the "open" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_OpenCmd(notUsed, interp, argc, argv) + ClientData notUsed; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int pipeline, fd, mode, prot, readWrite, permissions; + char *access; + FILE *f, *f2; + + if ((argc < 2) || (argc > 4)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " filename ?access? ?permissions?\"", (char *) NULL); + return TCL_ERROR; + } + prot = 0666; + if (argc == 2) { + mode = O_RDONLY; + access = "r"; + } else { + access = GetOpenMode(interp, argv[2], &mode); + if (access == NULL) { + return TCL_ERROR; + } + if (argc == 4) { + if (Tcl_GetInt(interp, argv[3], &prot) != TCL_OK) { + return TCL_ERROR; + } + } + } + + f = f2 = NULL; + readWrite = mode & (O_RDWR|O_RDONLY|O_WRONLY); + if (readWrite == O_RDONLY) { + permissions = TCL_FILE_READABLE; + } else if (readWrite == O_WRONLY) { + permissions = TCL_FILE_WRITABLE; + } else { + permissions = TCL_FILE_READABLE|TCL_FILE_WRITABLE; + } + + pipeline = 0; + if (argv[1][0] == '|') { + pipeline = 1; + } + + /* + * Open the file or create a process pipeline. + */ + + if (!pipeline) { + char *fileName; + Tcl_DString buffer; + + fileName = Tcl_TildeSubst(interp, argv[1], &buffer); + if (fileName == NULL) { + return TCL_ERROR; + } + fd = open(fileName, mode, prot); + Tcl_DStringFree(&buffer); + if (fd < 0) { + Tcl_AppendResult(interp, "couldn't open \"", argv[1], + "\": ", Tcl_PosixError(interp), (char *) NULL); + return TCL_ERROR; + } + f = fdopen(fd, access); + if (f == NULL) { + close(fd); + return TCL_ERROR; + } + Tcl_EnterFile(interp, f, permissions); + } else { + int *inPipePtr, *outPipePtr; + int cmdArgc, inPipe, outPipe, numPids, *pidPtr, errorId; + char **cmdArgv; + OpenFile *oFilePtr; + + if (Tcl_SplitList(interp, argv[1]+1, &cmdArgc, &cmdArgv) != TCL_OK) { + return TCL_ERROR; + } + inPipePtr = (permissions & TCL_FILE_WRITABLE) ? &inPipe : NULL; + outPipePtr = (permissions & TCL_FILE_READABLE) ? &outPipe : NULL; + inPipe = outPipe = errorId = -1; + numPids = Tcl_CreatePipeline(interp, cmdArgc, cmdArgv, + &pidPtr, inPipePtr, outPipePtr, &errorId); + ckfree((char *) cmdArgv); + if (numPids < 0) { + pipelineError: + if (f != NULL) { + fclose(f); + } + if (f2 != NULL) { + fclose(f2); + } + if (numPids > 0) { + Tcl_DetachPids(numPids, pidPtr); + ckfree((char *) pidPtr); + } + if (errorId != -1) { + close(errorId); + } + return TCL_ERROR; + } + if (permissions & TCL_FILE_READABLE) { + if (outPipe == -1) { + if (inPipe != -1) { + close(inPipe); + } + Tcl_AppendResult(interp, "can't read output from command:", + " standard output was redirected", (char *) NULL); + goto pipelineError; + } + f = fdopen(outPipe, "r"); + } + if (permissions & TCL_FILE_WRITABLE) { + if (inPipe == -1) { + Tcl_AppendResult(interp, "can't write input to command:", + " standard input was redirected", (char *) NULL); + goto pipelineError; + } + if (f != NULL) { + f2 = fdopen(inPipe, "w"); + } else { + f = fdopen(inPipe, "w"); + } + } + Tcl_EnterFile(interp, f, permissions); + oFilePtr = tclOpenFiles[fileno(f)]; + oFilePtr->f2 = f2; + oFilePtr->numPids = numPids; + oFilePtr->pidPtr = pidPtr; + oFilePtr->errorId = errorId; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * GetOpenMode -- + * + * description. + * + * Results: + * Normally, sets *modePtr to an access mode for passing to "open", + * and returns a string that can be used as the access mode in a + * subsequent call to "fdopen". If an error occurs, then returns + * NULL and sets interp->result to an error message. + * + * Side effects: + * None. + * + * Special note: + * This code is based on a prototype implementation contributed + * by Mark Diekhans. + * + *---------------------------------------------------------------------- + */ + +static char * +GetOpenMode(interp, string, modePtr) + Tcl_Interp *interp; /* Interpreter to use for error + * reporting. */ + char *string; /* Mode string, e.g. "r+" or + * "RDONLY CREAT". */ + int *modePtr; /* Where to store mode corresponding + * to string. */ +{ + int mode, modeArgc, c, i, gotRW; + char **modeArgv, *flag; +#define RW_MODES (O_RDONLY|O_WRONLY|O_RDWR) + + /* + * Check for the simpler fopen-like access modes (e.g. "r"). They + * are distinguished from the POSIX access modes by the presence + * of a lower-case first letter. + */ + + mode = 0; + if (islower(UCHAR(string[0]))) { + switch (string[0]) { + case 'r': + mode = O_RDONLY; + break; + case 'w': + mode = O_WRONLY|O_CREAT|O_TRUNC; + break; + case 'a': + mode = O_WRONLY|O_CREAT|O_APPEND; + break; + default: + error: + Tcl_AppendResult(interp, + "illegal access mode \"", string, "\"", (char *) NULL); + return NULL; + } + if (string[1] == '+') { + mode &= ~(O_RDONLY|O_WRONLY); + mode |= O_RDWR; + if (string[2] != 0) { + goto error; + } + } else if (string[1] != 0) { + goto error; + } + *modePtr = mode; + return string; + } + + /* + * The access modes are specified using a list of POSIX modes + * such as O_CREAT. + */ + + if (Tcl_SplitList(interp, string, &modeArgc, &modeArgv) != TCL_OK) { + Tcl_AddErrorInfo(interp, "\n while processing open access modes \""); + Tcl_AddErrorInfo(interp, string); + Tcl_AddErrorInfo(interp, "\""); + return NULL; + } + gotRW = 0; + for (i = 0; i < modeArgc; i++) { + flag = modeArgv[i]; + c = flag[0]; + if ((c == 'R') && (strcmp(flag, "RDONLY") == 0)) { + mode = (mode & ~RW_MODES) | O_RDONLY; + gotRW = 1; + } else if ((c == 'W') && (strcmp(flag, "WRONLY") == 0)) { + mode = (mode & ~RW_MODES) | O_WRONLY; + gotRW = 1; + } else if ((c == 'R') && (strcmp(flag, "RDWR") == 0)) { + mode = (mode & ~RW_MODES) | O_RDWR; + gotRW = 1; + } else if ((c == 'A') && (strcmp(flag, "APPEND") == 0)) { + mode |= O_APPEND; + } else if ((c == 'C') && (strcmp(flag, "CREAT") == 0)) { + mode |= O_CREAT; + } else if ((c == 'E') && (strcmp(flag, "EXCL") == 0)) { + mode |= O_EXCL; + } else if ((c == 'N') && (strcmp(flag, "NOCTTY") == 0)) { +#ifdef O_NOCTTY + mode |= O_NOCTTY; +#else + Tcl_AppendResult(interp, "access mode \"", flag, + "\" not supported by this system", (char *) NULL); + ckfree((char *) modeArgv); + return NULL; +#endif + } else if ((c == 'N') && (strcmp(flag, "NONBLOCK") == 0)) { +#ifdef O_NONBLOCK + mode |= O_NONBLOCK; +#else + mode |= O_NDELAY; +#endif + } else if ((c == 'T') && (strcmp(flag, "TRUNC") == 0)) { + mode |= O_TRUNC; + } else { + Tcl_AppendResult(interp, "invalid access mode \"", flag, + "\": must be RDONLY, WRONLY, RDWR, APPEND, CREAT", + " EXCL, NOCTTY, NONBLOCK, or TRUNC", (char *) NULL); + ckfree((char *) modeArgv); + return NULL; + } + } + ckfree((char *) modeArgv); + if (!gotRW) { + Tcl_AppendResult(interp, "access mode must include either", + " RDONLY, WRONLY, or RDWR", (char *) NULL); + return NULL; + } + *modePtr = mode; + + /* + * The calculation of fdopen access mode below isn't really correct, + * but it doesn't have to be. All it has to do is to disinguish + * read and write permissions, plus indicate append mode. + */ + + i = mode & RW_MODES; + if (i == O_RDONLY) { + return "r"; + } + if (mode & O_APPEND) { + if (i == O_WRONLY) { + return "a"; + } else { + return "a+"; + } + } + if (i == O_WRONLY) { + return "w"; + } + return "r+"; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_PidCmd -- + * + * This procedure is invoked to process the "pid" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_PidCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + FILE *f; + OpenFile *oFilePtr; + int i; + char string[50]; + + if (argc > 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " ?fileId?\"", (char *) NULL); + return TCL_ERROR; + } + if (argc == 1) { + sprintf(interp->result, "%d", getpid()); + } else { + if (Tcl_GetOpenFile(interp, argv[1], 0, 0, &f) != TCL_OK) { + return TCL_ERROR; + } + oFilePtr = tclOpenFiles[fileno(f)]; + for (i = 0; i < oFilePtr->numPids; i++) { + sprintf(string, "%d", oFilePtr->pidPtr[i]); + Tcl_AppendElement(interp, string); + } + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_PutsCmd -- + * + * This procedure is invoked to process the "puts" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_PutsCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + FILE *f; + int i, newline; + char *fileId; + + i = 1; + newline = 1; + if ((argc >= 2) && (strcmp(argv[1], "-nonewline") == 0)) { + newline = 0; + i++; + } + if ((i < (argc-3)) || (i >= argc)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + "\" ?-nonewline? ?fileId? string", (char *) NULL); + return TCL_ERROR; + } + + /* + * The code below provides backwards compatibility with an old + * form of the command that is no longer recommended or documented. + */ + + if (i == (argc-3)) { + if (strncmp(argv[i+2], "nonewline", strlen(argv[i+2])) != 0) { + Tcl_AppendResult(interp, "bad argument \"", argv[i+2], + "\": should be \"nonewline\"", (char *) NULL); + return TCL_ERROR; + } + newline = 0; + } + if (i == (argc-1)) { + fileId = "stdout"; + } else { + fileId = argv[i]; + i++; + } + + if (Tcl_GetOpenFile(interp, fileId, 1, 1, &f) != TCL_OK) { + return TCL_ERROR; + } + + clearerr(f); + fputs(argv[i], f); + if (newline) { + fputc('\n', f); + } + if (ferror(f)) { + Tcl_AppendResult(interp, "error writing \"", fileId, + "\": ", Tcl_PosixError(interp), (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_PwdCmd -- + * + * This procedure is invoked to process the "pwd" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_PwdCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + char buffer[MAXPATHLEN+1]; + + if (argc != 1) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], "\"", (char *) NULL); + return TCL_ERROR; + } + if (currentDir == NULL) { + if (getcwd(buffer, MAXPATHLEN+1) == NULL) { + if (errno == ERANGE) { + interp->result = "working directory name is too long"; + } else { + Tcl_AppendResult(interp, + "error getting working directory name: ", + Tcl_PosixError(interp), (char *) NULL); + } + return TCL_ERROR; + } + currentDir = (char *) ckalloc((unsigned) (strlen(buffer) + 1)); + strcpy(currentDir, buffer); + } + interp->result = currentDir; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ReadCmd -- + * + * This procedure is invoked to process the "read" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_ReadCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int bytesLeft, bytesRead, count; +#define READ_BUF_SIZE 4096 + char buffer[READ_BUF_SIZE+1]; + int newline, i; + FILE *f; + + if ((argc != 2) && (argc != 3)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " fileId ?numBytes?\" or \"", argv[0], + " ?-nonewline? fileId\"", (char *) NULL); + return TCL_ERROR; + } + i = 1; + newline = 1; + if ((argc == 3) && (strcmp(argv[1], "-nonewline") == 0)) { + newline = 0; + i++; + } + if (Tcl_GetOpenFile(interp, argv[i], 0, 1, &f) != TCL_OK) { + return TCL_ERROR; + } + + /* + * Compute how many bytes to read, and see whether the final + * newline should be dropped. + */ + + if ((argc >= (i + 2)) && isdigit(UCHAR(argv[i+1][0]))) { + if (Tcl_GetInt(interp, argv[i+1], &bytesLeft) != TCL_OK) { + return TCL_ERROR; + } + } else { + bytesLeft = 1<<30; + + /* + * The code below provides backward compatibility for an + * archaic earlier version of this command. + */ + + if (argc >= (i + 2)) { + if (strncmp(argv[i+1], "nonewline", strlen(argv[i+1])) == 0) { + newline = 0; + } else { + Tcl_AppendResult(interp, "bad argument \"", argv[i+1], + "\": should be \"nonewline\"", (char *) NULL); + return TCL_ERROR; + } + } + } + + /* + * Read the file in one or more chunks. + */ + + bytesRead = 0; + clearerr(f); + while (bytesLeft > 0) { + count = READ_BUF_SIZE; + if (bytesLeft < READ_BUF_SIZE) { + count = bytesLeft; + } + count = fread(buffer, 1, count, f); + if (ferror(f)) { + /* + * If the file is in non-blocking mode, break out of the + * loop and return any bytes that were read. + */ + + if ((errno == EWOULDBLOCK) && ((count > 0) || (bytesRead > 0))) { + clearerr(f); + bytesLeft = count; + } else { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "error reading \"", argv[i], + "\": ", Tcl_PosixError(interp), (char *) NULL); + return TCL_ERROR; + } + } + if (count == 0) { + break; + } + buffer[count] = 0; + Tcl_AppendResult(interp, buffer, (char *) NULL); + bytesLeft -= count; + bytesRead += count; + } + if ((newline == 0) && (bytesRead > 0) + && (interp->result[bytesRead-1] == '\n')) { + interp->result[bytesRead-1] = 0; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SeekCmd -- + * + * This procedure is invoked to process the "seek" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_SeekCmd(notUsed, interp, argc, argv) + ClientData notUsed; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + FILE *f; + int offset, mode; + + if ((argc != 3) && (argc != 4)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " fileId offset ?origin?\"", (char *) NULL); + return TCL_ERROR; + } + if (Tcl_GetOpenFile(interp, argv[1], 0, 0, &f) != TCL_OK) { + return TCL_ERROR; + } + if (Tcl_GetInt(interp, argv[2], &offset) != TCL_OK) { + return TCL_ERROR; + } + mode = SEEK_SET; + if (argc == 4) { + int length; + char c; + + length = strlen(argv[3]); + c = argv[3][0]; + if ((c == 's') && (strncmp(argv[3], "start", length) == 0)) { + mode = SEEK_SET; + } else if ((c == 'c') && (strncmp(argv[3], "current", length) == 0)) { + mode = SEEK_CUR; + } else if ((c == 'e') && (strncmp(argv[3], "end", length) == 0)) { + mode = SEEK_END; + } else { + Tcl_AppendResult(interp, "bad origin \"", argv[3], + "\": should be start, current, or end", (char *) NULL); + return TCL_ERROR; + } + } + clearerr(f); + if (fseek(f, (long) offset, mode) == -1) { + Tcl_AppendResult(interp, "error during seek: ", + Tcl_PosixError(interp), (char *) NULL); + return TCL_ERROR; + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SourceCmd -- + * + * This procedure is invoked to process the "source" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_SourceCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " fileName\"", (char *) NULL); + return TCL_ERROR; + } + return Tcl_EvalFile(interp, argv[1]); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_TellCmd -- + * + * This procedure is invoked to process the "tell" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_TellCmd(notUsed, interp, argc, argv) + ClientData notUsed; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + FILE *f; + + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " fileId\"", (char *) NULL); + return TCL_ERROR; + } + if (Tcl_GetOpenFile(interp, argv[1], 0, 0, &f) != TCL_OK) { + return TCL_ERROR; + } + sprintf(interp->result, "%d", ftell(f)); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_TimeCmd -- + * + * This procedure is invoked to process the "time" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_TimeCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int count, i, result; + double timePer; +#if NO_GETTOD + struct tms dummy2; + long start, stop; +#else + struct timeval start, stop; + struct timezone tz; + int micros; +#endif + + if (argc == 2) { + count = 1; + } else if (argc == 3) { + if (Tcl_GetInt(interp, argv[2], &count) != TCL_OK) { + return TCL_ERROR; + } + } else { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " command ?count?\"", (char *) NULL); + return TCL_ERROR; + } +#if NO_GETTOD + start = times(&dummy2); +#else + gettimeofday(&start, &tz); +#endif + for (i = count ; i > 0; i--) { + result = Tcl_Eval(interp, argv[1]); + if (result != TCL_OK) { + if (result == TCL_ERROR) { + char msg[60]; + sprintf(msg, "\n (\"time\" body line %d)", + interp->errorLine); + Tcl_AddErrorInfo(interp, msg); + } + return result; + } + } +#if NO_GETTOD + stop = times(&dummy2); + timePer = (((double) (stop - start))*1000000.0)/CLK_TCK; +#else + gettimeofday(&stop, &tz); + micros = (stop.tv_sec - start.tv_sec)*1000000 + + (stop.tv_usec - start.tv_usec); + timePer = micros; +#endif + Tcl_ResetResult(interp); + sprintf(interp->result, "%.0f microseconds per iteration", timePer/count); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * CleanupChildren -- + * + * This is a utility procedure used to wait for child processes + * to exit, record information about abnormal exits, and then + * collect any stderr output generated by them. + * + * Results: + * The return value is a standard Tcl result. If anything at + * weird happened with the child processes, TCL_ERROR is returned + * and a message is left in interp->result. + * + * Side effects: + * If the last character of interp->result is a newline, then it + * is removed unless keepNewline is non-zero. File errorId gets + * closed, and pidPtr is freed back to the storage allocator. + * + *---------------------------------------------------------------------- + */ + +static int +CleanupChildren(interp, numPids, pidPtr, errorId, keepNewline) + Tcl_Interp *interp; /* Used for error messages. */ + int numPids; /* Number of entries in pidPtr array. */ + int *pidPtr; /* Array of process ids of children. */ + int errorId; /* File descriptor index for file containing + * stderr output from pipeline. -1 means + * there isn't any stderr output. */ + int keepNewline; /* Non-zero means don't discard trailing + * newline. */ +{ + int result = TCL_OK; + int i, pid, length, abnormalExit; + WAIT_STATUS_TYPE waitStatus; + + abnormalExit = 0; + for (i = 0; i < numPids; i++) { + pid = waitpid(pidPtr[i], (int *) &waitStatus, 0); + if (pid == -1) { + Tcl_AppendResult(interp, "error waiting for process to exit: ", + Tcl_PosixError(interp), (char *) NULL); + continue; + } + + /* + * Create error messages for unusual process exits. An + * extra newline gets appended to each error message, but + * it gets removed below (in the same fashion that an + * extra newline in the command's output is removed). + */ + + if (!WIFEXITED(waitStatus) || (WEXITSTATUS(waitStatus) != 0)) { + char msg1[20], msg2[20]; + + result = TCL_ERROR; + sprintf(msg1, "%d", pid); + if (WIFEXITED(waitStatus)) { + sprintf(msg2, "%d", WEXITSTATUS(waitStatus)); + Tcl_SetErrorCode(interp, "CHILDSTATUS", msg1, msg2, + (char *) NULL); + abnormalExit = 1; + } else if (WIFSIGNALED(waitStatus)) { + char *p; + + p = Tcl_SignalMsg((int) (WTERMSIG(waitStatus))); + Tcl_SetErrorCode(interp, "CHILDKILLED", msg1, + Tcl_SignalId((int) (WTERMSIG(waitStatus))), p, + (char *) NULL); + Tcl_AppendResult(interp, "child killed: ", p, "\n", + (char *) NULL); + } else if (WIFSTOPPED(waitStatus)) { + char *p; + + p = Tcl_SignalMsg((int) (WSTOPSIG(waitStatus))); + Tcl_SetErrorCode(interp, "CHILDSUSP", msg1, + Tcl_SignalId((int) (WSTOPSIG(waitStatus))), p, (char *) NULL); + Tcl_AppendResult(interp, "child suspended: ", p, "\n", + (char *) NULL); + } else { + Tcl_AppendResult(interp, + "child wait status didn't make sense\n", + (char *) NULL); + } + } + } + ckfree((char *) pidPtr); + + /* + * Read the standard error file. If there's anything there, + * then return an error and add the file's contents to the result + * string. + */ + + if (errorId >= 0) { + while (1) { +# define BUFFER_SIZE 1000 + char buffer[BUFFER_SIZE+1]; + int count; + + count = read(errorId, buffer, (size_t) BUFFER_SIZE); + + if (count == 0) { + break; + } + result = TCL_ERROR; + if (count < 0) { + Tcl_AppendResult(interp, + "error reading stderr output file: ", + Tcl_PosixError(interp), (char *) NULL); + break; + } + buffer[count] = 0; + Tcl_AppendResult(interp, buffer, (char *) NULL); + } + close(errorId); + } + + /* + * If a child exited abnormally but didn't output any error information + * at all, generate an error message here. + */ + + if (abnormalExit && (*interp->result == 0)) { + Tcl_AppendResult(interp, "child process exited abnormally", + (char *) NULL); + } + + /* + * If the last character of interp->result is a newline, then remove + * the newline character (the newline would just confuse things). + * Special hack: must replace the old terminating null character + * as a signal to Tcl_AppendResult et al. that we've mucked with + * the string. + */ + + length = strlen(interp->result); + if (!keepNewline && (length > 0) && (interp->result[length-1] == '\n')) { + interp->result[length-1] = '\0'; + interp->result[length] = 'x'; + } + + return result; +} diff --git a/vendor/x11iraf/obm/Tcl/tclUnixStr.c b/vendor/x11iraf/obm/Tcl/tclUnixStr.c new file mode 100644 index 00000000..0ac38b19 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/tclUnixStr.c @@ -0,0 +1,737 @@ +/* + * tclUnixStr.c -- + * + * This file contains procedures that generate strings + * corresponding to various UNIX-related codes, such + * as errno and signals. + * + * Copyright (c) 1991-1993 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. + */ + +#ifndef lint +static char rcsid[] = "$Header: /user6/ouster/tcl/RCS/tclUnixStr.c,v 1.17 93/09/09 14:47:55 ouster Exp $ SPRITE (Berkeley)"; +#endif /* not lint */ + +#include "tclInt.h" +#include "tclUnix.h" + +/* + *---------------------------------------------------------------------- + * + * Tcl_ErrnoId -- + * + * Return a textual identifier for the current errno value. + * + * Results: + * This procedure returns a machine-readable textual identifier + * that corresponds to the current errno value (e.g. "EPERM"). + * The identifier is the same as the #define name in errno.h. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_ErrnoId() +{ + switch (errno) { +#ifdef E2BIG + case E2BIG: return "E2BIG"; +#endif +#ifdef EACCES + case EACCES: return "EACCES"; +#endif +#ifdef EADDRINUSE + case EADDRINUSE: return "EADDRINUSE"; +#endif +#ifdef EADDRNOTAVAIL + case EADDRNOTAVAIL: return "EADDRNOTAVAIL"; +#endif +#ifdef EADV + case EADV: return "EADV"; +#endif +#ifdef EAFNOSUPPORT + case EAFNOSUPPORT: return "EAFNOSUPPORT"; +#endif +#ifdef EAGAIN + case EAGAIN: return "EAGAIN"; +#endif +#ifdef EALIGN + case EALIGN: return "EALIGN"; +#endif +#ifdef EALREADY + case EALREADY: return "EALREADY"; +#endif +#ifdef EBADE + case EBADE: return "EBADE"; +#endif +#ifdef EBADF + case EBADF: return "EBADF"; +#endif +#ifdef EBADFD + case EBADFD: return "EBADFD"; +#endif +#ifdef EBADMSG + case EBADMSG: return "EBADMSG"; +#endif +#ifdef EBADR + case EBADR: return "EBADR"; +#endif +#ifdef EBADRPC + case EBADRPC: return "EBADRPC"; +#endif +#ifdef EBADRQC + case EBADRQC: return "EBADRQC"; +#endif +#ifdef EBADSLT + case EBADSLT: return "EBADSLT"; +#endif +#ifdef EBFONT + case EBFONT: return "EBFONT"; +#endif +#ifdef EBUSY + case EBUSY: return "EBUSY"; +#endif +#ifdef ECHILD + case ECHILD: return "ECHILD"; +#endif +#ifdef ECHRNG + case ECHRNG: return "ECHRNG"; +#endif +#ifdef ECOMM + case ECOMM: return "ECOMM"; +#endif +#ifdef ECONNABORTED + case ECONNABORTED: return "ECONNABORTED"; +#endif +#ifdef ECONNREFUSED + case ECONNREFUSED: return "ECONNREFUSED"; +#endif +#ifdef ECONNRESET + case ECONNRESET: return "ECONNRESET"; +#endif +#if defined(EDEADLK) && (!defined(EWOULDBLOCK) || (EDEADLK != EWOULDBLOCK)) + case EDEADLK: return "EDEADLK"; +#endif +#ifdef EDEADLOCK +#if (EDEADLOCK != EDEADLK) && (!(!defined(EWOULDBLOCK) || (EDEADLK != EWOULDBLOCK))) + case EDEADLOCK: return "EDEADLOCK"; +#endif +#endif +#ifdef EDESTADDRREQ + case EDESTADDRREQ: return "EDESTADDRREQ"; +#endif +#ifdef EDIRTY + case EDIRTY: return "EDIRTY"; +#endif +#ifdef EDOM + case EDOM: return "EDOM"; +#endif +#ifdef EDOTDOT + case EDOTDOT: return "EDOTDOT"; +#endif +#ifdef EDQUOT + case EDQUOT: return "EDQUOT"; +#endif +#ifdef EDUPPKG + case EDUPPKG: return "EDUPPKG"; +#endif +#ifdef EEXIST + case EEXIST: return "EEXIST"; +#endif +#ifdef EFAULT + case EFAULT: return "EFAULT"; +#endif +#ifdef EFBIG + case EFBIG: return "EFBIG"; +#endif +#ifdef EHOSTDOWN + case EHOSTDOWN: return "EHOSTDOWN"; +#endif +#ifdef EHOSTUNREACH + case EHOSTUNREACH: return "EHOSTUNREACH"; +#endif +#ifdef EIDRM + case EIDRM: return "EIDRM"; +#endif +#ifdef EINIT + case EINIT: return "EINIT"; +#endif +#ifdef EINPROGRESS + case EINPROGRESS: return "EINPROGRESS"; +#endif +#ifdef EINTR + case EINTR: return "EINTR"; +#endif +#ifdef EINVAL + case EINVAL: return "EINVAL"; +#endif +#ifdef EIO + case EIO: return "EIO"; +#endif +#ifdef EISCONN + case EISCONN: return "EISCONN"; +#endif +#ifdef EISDIR + case EISDIR: return "EISDIR"; +#endif +#ifdef EISNAME + case EISNAM: return "EISNAM"; +#endif +#ifdef ELBIN + case ELBIN: return "ELBIN"; +#endif +#ifdef EL2HLT + case EL2HLT: return "EL2HLT"; +#endif +#ifdef EL2NSYNC + case EL2NSYNC: return "EL2NSYNC"; +#endif +#ifdef EL3HLT + case EL3HLT: return "EL3HLT"; +#endif +#ifdef EL3RST + case EL3RST: return "EL3RST"; +#endif +#ifdef ELIBACC + case ELIBACC: return "ELIBACC"; +#endif +#ifdef ELIBBAD + case ELIBBAD: return "ELIBBAD"; +#endif +#ifdef ELIBEXEC + case ELIBEXEC: return "ELIBEXEC"; +#endif +#ifdef ELIBMAX + case ELIBMAX: return "ELIBMAX"; +#endif +#ifdef ELIBSCN + case ELIBSCN: return "ELIBSCN"; +#endif +#ifdef ELNRNG + case ELNRNG: return "ELNRNG"; +#endif +#ifdef ELOOP + case ELOOP: return "ELOOP"; +#endif +#ifdef EMFILE + case EMFILE: return "EMFILE"; +#endif +#ifdef EMLINK + case EMLINK: return "EMLINK"; +#endif +#ifdef EMSGSIZE + case EMSGSIZE: return "EMSGSIZE"; +#endif +#ifdef EMULTIHOP + case EMULTIHOP: return "EMULTIHOP"; +#endif +#ifdef ENAMETOOLONG + case ENAMETOOLONG: return "ENAMETOOLONG"; +#endif +#ifdef ENAVAIL + case ENAVAIL: return "ENAVAIL"; +#endif +#ifdef ENET + case ENET: return "ENET"; +#endif +#ifdef ENETDOWN + case ENETDOWN: return "ENETDOWN"; +#endif +#ifdef ENETRESET + case ENETRESET: return "ENETRESET"; +#endif +#ifdef ENETUNREACH + case ENETUNREACH: return "ENETUNREACH"; +#endif +#ifdef ENFILE + case ENFILE: return "ENFILE"; +#endif +#ifdef ENOANO + case ENOANO: return "ENOANO"; +#endif +#if defined(ENOBUFS) && (!defined(ENOSR) || (ENOBUFS != ENOSR)) + case ENOBUFS: return "ENOBUFS"; +#endif +#ifdef ENOCSI + case ENOCSI: return "ENOCSI"; +#endif +#ifdef ENODATA + case ENODATA: return "ENODATA"; +#endif +#ifdef ENODEV + case ENODEV: return "ENODEV"; +#endif +#ifdef ENOENT + case ENOENT: return "ENOENT"; +#endif +#ifdef ENOEXEC + case ENOEXEC: return "ENOEXEC"; +#endif +#ifdef ENOLCK + case ENOLCK: return "ENOLCK"; +#endif +#ifdef ENOLINK + case ENOLINK: return "ENOLINK"; +#endif +#ifdef ENOMEM + case ENOMEM: return "ENOMEM"; +#endif +#ifdef ENOMSG + case ENOMSG: return "ENOMSG"; +#endif +#ifdef ENONET + case ENONET: return "ENONET"; +#endif +#ifdef ENOPKG + case ENOPKG: return "ENOPKG"; +#endif +#ifdef ENOPROTOOPT + case ENOPROTOOPT: return "ENOPROTOOPT"; +#endif +#ifdef ENOSPC + case ENOSPC: return "ENOSPC"; +#endif +#ifdef ENOSR + case ENOSR: return "ENOSR"; +#endif +#if defined(ENOSTR) && (!defined(ENOTTY) || (ENOTTY != ENOSTR)) + case ENOSTR: return "ENOSTR"; +#endif +#ifdef ENOSYM + case ENOSYM: return "ENOSYM"; +#endif +#ifdef ENOSYS + case ENOSYS: return "ENOSYS"; +#endif +#ifdef ENOTBLK + case ENOTBLK: return "ENOTBLK"; +#endif +#ifdef ENOTCONN + case ENOTCONN: return "ENOTCONN"; +#endif +#ifdef ENOTDIR + case ENOTDIR: return "ENOTDIR"; +#endif +#if defined(ENOTEMPTY) && (!defined(EEXIST) || (ENOTEMPTY != EEXIST)) + case ENOTEMPTY: return "ENOTEMPTY"; +#endif +#ifdef ENOTNAM + case ENOTNAM: return "ENOTNAM"; +#endif +#ifdef ENOTSOCK + case ENOTSOCK: return "ENOTSOCK"; +#endif +#ifdef ENOTTY + case ENOTTY: return "ENOTTY"; +#endif +#ifdef ENOTUNIQ + case ENOTUNIQ: return "ENOTUNIQ"; +#endif +#ifdef ENXIO + case ENXIO: return "ENXIO"; +#endif +#ifdef EOPNOTSUPP + case EOPNOTSUPP: return "EOPNOTSUPP"; +#endif +#ifdef EPERM + case EPERM: return "EPERM"; +#endif +#ifdef EPFNOSUPPORT + case EPFNOSUPPORT: return "EPFNOSUPPORT"; +#endif +#ifdef EPIPE + case EPIPE: return "EPIPE"; +#endif +#ifdef EPROCLIM + case EPROCLIM: return "EPROCLIM"; +#endif +#ifdef EPROCUNAVAIL + case EPROCUNAVAIL: return "EPROCUNAVAIL"; +#endif +#ifdef EPROGMISMATCH + case EPROGMISMATCH: return "EPROGMISMATCH"; +#endif +#ifdef EPROGUNAVAIL + case EPROGUNAVAIL: return "EPROGUNAVAIL"; +#endif +#ifdef EPROTO + case EPROTO: return "EPROTO"; +#endif +#ifdef EPROTONOSUPPORT + case EPROTONOSUPPORT: return "EPROTONOSUPPORT"; +#endif +#ifdef EPROTOTYPE + case EPROTOTYPE: return "EPROTOTYPE"; +#endif +#ifdef ERANGE + case ERANGE: return "ERANGE"; +#endif +#if defined(EREFUSED) && (!defined(ECONNREFUSED) || (EREFUSED != ECONNREFUSED)) + case EREFUSED: return "EREFUSED"; +#endif +#ifdef EREMCHG + case EREMCHG: return "EREMCHG"; +#endif +#ifdef EREMDEV + case EREMDEV: return "EREMDEV"; +#endif +#ifdef EREMOTE + case EREMOTE: return "EREMOTE"; +#endif +#ifdef EREMOTEIO + case EREMOTEIO: return "EREMOTEIO"; +#endif +#ifdef EREMOTERELEASE + case EREMOTERELEASE: return "EREMOTERELEASE"; +#endif +#ifdef EROFS + case EROFS: return "EROFS"; +#endif +#ifdef ERPCMISMATCH + case ERPCMISMATCH: return "ERPCMISMATCH"; +#endif +#ifdef ERREMOTE + case ERREMOTE: return "ERREMOTE"; +#endif +#ifdef ESHUTDOWN + case ESHUTDOWN: return "ESHUTDOWN"; +#endif +#ifdef ESOCKTNOSUPPORT + case ESOCKTNOSUPPORT: return "ESOCKTNOSUPPORT"; +#endif +#ifdef ESPIPE + case ESPIPE: return "ESPIPE"; +#endif +#ifdef ESRCH + case ESRCH: return "ESRCH"; +#endif +#ifdef ESRMNT + case ESRMNT: return "ESRMNT"; +#endif +#ifdef ESTALE + case ESTALE: return "ESTALE"; +#endif +#ifdef ESUCCESS + case ESUCCESS: return "ESUCCESS"; +#endif +#ifdef ETIME + case ETIME: return "ETIME"; +#endif +#ifdef ETIMEDOUT + case ETIMEDOUT: return "ETIMEDOUT"; +#endif +#ifdef ETOOMANYREFS + case ETOOMANYREFS: return "ETOOMANYREFS"; +#endif +#ifdef ETXTBSY + case ETXTBSY: return "ETXTBSY"; +#endif +#ifdef EUCLEAN + case EUCLEAN: return "EUCLEAN"; +#endif +#ifdef EUNATCH + case EUNATCH: return "EUNATCH"; +#endif +#ifdef EUSERS + case EUSERS: return "EUSERS"; +#endif +#ifdef EVERSION + case EVERSION: return "EVERSION"; +#endif +#if defined(EWOULDBLOCK) && (!defined(EAGAIN) || (EWOULDBLOCK != EAGAIN)) + case EWOULDBLOCK: return "EWOULDBLOCK"; +#endif +#ifdef EXDEV + case EXDEV: return "EXDEV"; +#endif +#ifdef EXFULL + case EXFULL: return "EXFULL"; +#endif + } + return "unknown error"; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SignalId -- + * + * Return a textual identifier for a signal number. + * + * Results: + * This procedure returns a machine-readable textual identifier + * that corresponds to sig. The identifier is the same as the + * #define name in signal.h. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_SignalId(sig) + int sig; /* Number of signal. */ +{ + switch (sig) { +#ifdef SIGABRT + case SIGABRT: return "SIGABRT"; +#endif +#ifdef SIGALRM + case SIGALRM: return "SIGALRM"; +#endif +#ifdef SIGBUS + case SIGBUS: return "SIGBUS"; +#endif +#ifdef SIGCHLD + case SIGCHLD: return "SIGCHLD"; +#endif +#if defined(SIGCLD) && (!defined(SIGCHLD) || (SIGCLD != SIGCHLD)) + case SIGCLD: return "SIGCLD"; +#endif +#ifdef SIGCONT + case SIGCONT: return "SIGCONT"; +#endif +#if defined(SIGEMT) && (!defined(SIGXCPU) || (SIGEMT != SIGXCPU)) + case SIGEMT: return "SIGEMT"; +#endif +#ifdef SIGFPE + case SIGFPE: return "SIGFPE"; +#endif +#ifdef SIGHUP + case SIGHUP: return "SIGHUP"; +#endif +#ifdef SIGILL + case SIGILL: return "SIGILL"; +#endif +#ifdef SIGINT + case SIGINT: return "SIGINT"; +#endif +#ifdef SIGIO + case SIGIO: return "SIGIO"; +#endif +#if defined(SIGIOT) && (!defined(SIGABRT) || (SIGIOT != SIGABRT)) + case SIGIOT: return "SIGIOT"; +#endif +#ifdef SIGKILL + case SIGKILL: return "SIGKILL"; +#endif +#if defined(SIGLOST) && (!defined(SIGIOT) || (SIGLOST != SIGIOT)) && (!defined(SIGURG) || (SIGLOST != SIGURG)) + case SIGLOST: return "SIGLOST"; +#endif +#ifdef SIGPIPE + case SIGPIPE: return "SIGPIPE"; +#endif +#if defined(SIGPOLL) && (!defined(SIGIO) || (SIGPOLL != SIGIO)) + case SIGPOLL: return "SIGPOLL"; +#endif +#ifdef SIGPROF + case SIGPROF: return "SIGPROF"; +#endif +#if defined(SIGPWR) && (!defined(SIGXFSZ) || (SIGPWR != SIGXFSZ)) + case SIGPWR: return "SIGPWR"; +#endif +#ifdef SIGQUIT + case SIGQUIT: return "SIGQUIT"; +#endif +#ifdef SIGSEGV + case SIGSEGV: return "SIGSEGV"; +#endif +#ifdef SIGSTOP + case SIGSTOP: return "SIGSTOP"; +#endif +#ifdef SIGSYS + case SIGSYS: return "SIGSYS"; +#endif +#ifdef SIGTERM + case SIGTERM: return "SIGTERM"; +#endif +#ifdef SIGTRAP + case SIGTRAP: return "SIGTRAP"; +#endif +#ifdef SIGTSTP + case SIGTSTP: return "SIGTSTP"; +#endif +#ifdef SIGTTIN + case SIGTTIN: return "SIGTTIN"; +#endif +#ifdef SIGTTOU + case SIGTTOU: return "SIGTTOU"; +#endif +#if defined(SIGURG) && (!defined(SIGIO) || (SIGURG != SIGIO)) + case SIGURG: return "SIGURG"; +#endif +#if defined(SIGUSR1) && (!defined(SIGIO) || (SIGUSR1 != SIGIO)) + case SIGUSR1: return "SIGUSR1"; +#endif +#if defined(SIGUSR2) && (!defined(SIGURG) || (SIGUSR2 != SIGURG)) + case SIGUSR2: return "SIGUSR2"; +#endif +#ifdef SIGVTALRM + case SIGVTALRM: return "SIGVTALRM"; +#endif +#ifdef SIGWINCH + case SIGWINCH: return "SIGWINCH"; +#endif +#ifdef SIGXCPU + case SIGXCPU: return "SIGXCPU"; +#endif +#ifdef SIGXFSZ + case SIGXFSZ: return "SIGXFSZ"; +#endif + } + return "unknown signal"; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SignalMsg -- + * + * Return a human-readable message describing a signal. + * + * Results: + * This procedure returns a string describing sig that should + * make sense to a human. It may not be easy for a machine + * to parse. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_SignalMsg(sig) + int sig; /* Number of signal. */ +{ + switch (sig) { +#ifdef SIGABRT + case SIGABRT: return "SIGABRT"; +#endif +#ifdef SIGALRM + case SIGALRM: return "alarm clock"; +#endif +#ifdef SIGBUS + case SIGBUS: return "bus error"; +#endif +#ifdef SIGCHLD + case SIGCHLD: return "child status changed"; +#endif +#if defined(SIGCLD) && (!defined(SIGCHLD) || (SIGCLD != SIGCHLD)) + case SIGCLD: return "child status changed"; +#endif +#ifdef SIGCONT + case SIGCONT: return "continue after stop"; +#endif +#if defined(SIGEMT) && (!defined(SIGXCPU) || (SIGEMT != SIGXCPU)) + case SIGEMT: return "EMT instruction"; +#endif +#ifdef SIGFPE + case SIGFPE: return "floating-point exception"; +#endif +#ifdef SIGHUP + case SIGHUP: return "hangup"; +#endif +#ifdef SIGILL + case SIGILL: return "illegal instruction"; +#endif +#ifdef SIGINT + case SIGINT: return "interrupt"; +#endif +#ifdef SIGIO + case SIGIO: return "input/output possible on file"; +#endif +#if defined(SIGIOT) && (!defined(SIGABRT) || (SIGABRT != SIGIOT)) + case SIGIOT: return "IOT instruction"; +#endif +#ifdef SIGKILL + case SIGKILL: return "kill signal"; +#endif +#if defined(SIGLOST) && (!defined(SIGIOT) || (SIGLOST != SIGIOT)) && (!defined(SIGURG) || (SIGLOST != SIGURG)) + case SIGLOST: return "resource lost"; +#endif +#ifdef SIGPIPE + case SIGPIPE: return "write on pipe with no readers"; +#endif +#if defined(SIGPOLL) && (!defined(SIGIO) || (SIGPOLL != SIGIO)) + case SIGPOLL: return "input/output possible on file"; +#endif +#ifdef SIGPROF + case SIGPROF: return "profiling alarm"; +#endif +#if defined(SIGPWR) && (!defined(SIGXFSZ) || (SIGPWR != SIGXFSZ)) + case SIGPWR: return "power-fail restart"; +#endif +#ifdef SIGQUIT + case SIGQUIT: return "quit signal"; +#endif +#ifdef SIGSEGV + case SIGSEGV: return "segmentation violation"; +#endif +#ifdef SIGSTOP + case SIGSTOP: return "stop"; +#endif +#ifdef SIGSYS + case SIGSYS: return "bad argument to system call"; +#endif +#ifdef SIGTERM + case SIGTERM: return "software termination signal"; +#endif +#ifdef SIGTRAP + case SIGTRAP: return "trace trap"; +#endif +#ifdef SIGTSTP + case SIGTSTP: return "stop signal from tty"; +#endif +#ifdef SIGTTIN + case SIGTTIN: return "background tty read"; +#endif +#ifdef SIGTTOU + case SIGTTOU: return "background tty write"; +#endif +#if defined(SIGURG) && (!defined(SIGIO) || (SIGURG != SIGIO)) + case SIGURG: return "urgent I/O condition"; +#endif +#if defined(SIGUSR1) && (!defined(SIGIO) || (SIGUSR1 != SIGIO)) + case SIGUSR1: return "user-defined signal 1"; +#endif +#if defined(SIGUSR2) && (!defined(SIGURG) || (SIGUSR2 != SIGURG)) + case SIGUSR2: return "user-defined signal 2"; +#endif +#ifdef SIGVTALRM + case SIGVTALRM: return "virtual time alarm"; +#endif +#ifdef SIGWINCH + case SIGWINCH: return "window changed"; +#endif +#ifdef SIGXCPU + case SIGXCPU: return "exceeded CPU time limit"; +#endif +#ifdef SIGXFSZ + case SIGXFSZ: return "exceeded file size limit"; +#endif + } + return "unknown signal"; +} diff --git a/vendor/x11iraf/obm/Tcl/tclUnixStr.c.OLD b/vendor/x11iraf/obm/Tcl/tclUnixStr.c.OLD new file mode 100644 index 00000000..454f30a7 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/tclUnixStr.c.OLD @@ -0,0 +1,735 @@ +/* + * tclUnixStr.c -- + * + * This file contains procedures that generate strings + * corresponding to various UNIX-related codes, such + * as errno and signals. + * + * Copyright (c) 1991-1993 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. + */ + +#ifndef lint +static char rcsid[] = "$Header: /user6/ouster/tcl/RCS/tclUnixStr.c,v 1.17 93/09/09 14:47:55 ouster Exp $ SPRITE (Berkeley)"; +#endif /* not lint */ + +#include "tclInt.h" +#include "tclUnix.h" + +/* + *---------------------------------------------------------------------- + * + * Tcl_ErrnoId -- + * + * Return a textual identifier for the current errno value. + * + * Results: + * This procedure returns a machine-readable textual identifier + * that corresponds to the current errno value (e.g. "EPERM"). + * The identifier is the same as the #define name in errno.h. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_ErrnoId() +{ + switch (errno) { +#ifdef E2BIG + case E2BIG: return "E2BIG"; +#endif +#ifdef EACCES + case EACCES: return "EACCES"; +#endif +#ifdef EADDRINUSE + case EADDRINUSE: return "EADDRINUSE"; +#endif +#ifdef EADDRNOTAVAIL + case EADDRNOTAVAIL: return "EADDRNOTAVAIL"; +#endif +#ifdef EADV + case EADV: return "EADV"; +#endif +#ifdef EAFNOSUPPORT + case EAFNOSUPPORT: return "EAFNOSUPPORT"; +#endif +#ifdef EAGAIN + case EAGAIN: return "EAGAIN"; +#endif +#ifdef EALIGN + case EALIGN: return "EALIGN"; +#endif +#ifdef EALREADY + case EALREADY: return "EALREADY"; +#endif +#ifdef EBADE + case EBADE: return "EBADE"; +#endif +#ifdef EBADF + case EBADF: return "EBADF"; +#endif +#ifdef EBADFD + case EBADFD: return "EBADFD"; +#endif +#ifdef EBADMSG + case EBADMSG: return "EBADMSG"; +#endif +#ifdef EBADR + case EBADR: return "EBADR"; +#endif +#ifdef EBADRPC + case EBADRPC: return "EBADRPC"; +#endif +#ifdef EBADRQC + case EBADRQC: return "EBADRQC"; +#endif +#ifdef EBADSLT + case EBADSLT: return "EBADSLT"; +#endif +#ifdef EBFONT + case EBFONT: return "EBFONT"; +#endif +#ifdef EBUSY + case EBUSY: return "EBUSY"; +#endif +#ifdef ECHILD + case ECHILD: return "ECHILD"; +#endif +#ifdef ECHRNG + case ECHRNG: return "ECHRNG"; +#endif +#ifdef ECOMM + case ECOMM: return "ECOMM"; +#endif +#ifdef ECONNABORTED + case ECONNABORTED: return "ECONNABORTED"; +#endif +#ifdef ECONNREFUSED + case ECONNREFUSED: return "ECONNREFUSED"; +#endif +#ifdef ECONNRESET + case ECONNRESET: return "ECONNRESET"; +#endif +#if defined(EDEADLK) && (!defined(EWOULDBLOCK) || (EDEADLK != EWOULDBLOCK)) + case EDEADLK: return "EDEADLK"; +#endif +#ifdef EDEADLOCK + case EDEADLOCK: return "EDEADLOCK"; +#endif +#ifdef EDESTADDRREQ + case EDESTADDRREQ: return "EDESTADDRREQ"; +#endif +#ifdef EDIRTY + case EDIRTY: return "EDIRTY"; +#endif +#ifdef EDOM + case EDOM: return "EDOM"; +#endif +#ifdef EDOTDOT + case EDOTDOT: return "EDOTDOT"; +#endif +#ifdef EDQUOT + case EDQUOT: return "EDQUOT"; +#endif +#ifdef EDUPPKG + case EDUPPKG: return "EDUPPKG"; +#endif +#ifdef EEXIST + case EEXIST: return "EEXIST"; +#endif +#ifdef EFAULT + case EFAULT: return "EFAULT"; +#endif +#ifdef EFBIG + case EFBIG: return "EFBIG"; +#endif +#ifdef EHOSTDOWN + case EHOSTDOWN: return "EHOSTDOWN"; +#endif +#ifdef EHOSTUNREACH + case EHOSTUNREACH: return "EHOSTUNREACH"; +#endif +#ifdef EIDRM + case EIDRM: return "EIDRM"; +#endif +#ifdef EINIT + case EINIT: return "EINIT"; +#endif +#ifdef EINPROGRESS + case EINPROGRESS: return "EINPROGRESS"; +#endif +#ifdef EINTR + case EINTR: return "EINTR"; +#endif +#ifdef EINVAL + case EINVAL: return "EINVAL"; +#endif +#ifdef EIO + case EIO: return "EIO"; +#endif +#ifdef EISCONN + case EISCONN: return "EISCONN"; +#endif +#ifdef EISDIR + case EISDIR: return "EISDIR"; +#endif +#ifdef EISNAME + case EISNAM: return "EISNAM"; +#endif +#ifdef ELBIN + case ELBIN: return "ELBIN"; +#endif +#ifdef EL2HLT + case EL2HLT: return "EL2HLT"; +#endif +#ifdef EL2NSYNC + case EL2NSYNC: return "EL2NSYNC"; +#endif +#ifdef EL3HLT + case EL3HLT: return "EL3HLT"; +#endif +#ifdef EL3RST + case EL3RST: return "EL3RST"; +#endif +#ifdef ELIBACC + case ELIBACC: return "ELIBACC"; +#endif +#ifdef ELIBBAD + case ELIBBAD: return "ELIBBAD"; +#endif +#ifdef ELIBEXEC + case ELIBEXEC: return "ELIBEXEC"; +#endif +#ifdef ELIBMAX + case ELIBMAX: return "ELIBMAX"; +#endif +#ifdef ELIBSCN + case ELIBSCN: return "ELIBSCN"; +#endif +#ifdef ELNRNG + case ELNRNG: return "ELNRNG"; +#endif +#ifdef ELOOP + case ELOOP: return "ELOOP"; +#endif +#ifdef EMFILE + case EMFILE: return "EMFILE"; +#endif +#ifdef EMLINK + case EMLINK: return "EMLINK"; +#endif +#ifdef EMSGSIZE + case EMSGSIZE: return "EMSGSIZE"; +#endif +#ifdef EMULTIHOP + case EMULTIHOP: return "EMULTIHOP"; +#endif +#ifdef ENAMETOOLONG + case ENAMETOOLONG: return "ENAMETOOLONG"; +#endif +#ifdef ENAVAIL + case ENAVAIL: return "ENAVAIL"; +#endif +#ifdef ENET + case ENET: return "ENET"; +#endif +#ifdef ENETDOWN + case ENETDOWN: return "ENETDOWN"; +#endif +#ifdef ENETRESET + case ENETRESET: return "ENETRESET"; +#endif +#ifdef ENETUNREACH + case ENETUNREACH: return "ENETUNREACH"; +#endif +#ifdef ENFILE + case ENFILE: return "ENFILE"; +#endif +#ifdef ENOANO + case ENOANO: return "ENOANO"; +#endif +#if defined(ENOBUFS) && (!defined(ENOSR) || (ENOBUFS != ENOSR)) + case ENOBUFS: return "ENOBUFS"; +#endif +#ifdef ENOCSI + case ENOCSI: return "ENOCSI"; +#endif +#ifdef ENODATA + case ENODATA: return "ENODATA"; +#endif +#ifdef ENODEV + case ENODEV: return "ENODEV"; +#endif +#ifdef ENOENT + case ENOENT: return "ENOENT"; +#endif +#ifdef ENOEXEC + case ENOEXEC: return "ENOEXEC"; +#endif +#ifdef ENOLCK + case ENOLCK: return "ENOLCK"; +#endif +#ifdef ENOLINK + case ENOLINK: return "ENOLINK"; +#endif +#ifdef ENOMEM + case ENOMEM: return "ENOMEM"; +#endif +#ifdef ENOMSG + case ENOMSG: return "ENOMSG"; +#endif +#ifdef ENONET + case ENONET: return "ENONET"; +#endif +#ifdef ENOPKG + case ENOPKG: return "ENOPKG"; +#endif +#ifdef ENOPROTOOPT + case ENOPROTOOPT: return "ENOPROTOOPT"; +#endif +#ifdef ENOSPC + case ENOSPC: return "ENOSPC"; +#endif +#ifdef ENOSR + case ENOSR: return "ENOSR"; +#endif +#if defined(ENOSTR) && (!defined(ENOTTY) || (ENOTTY != ENOSTR)) + case ENOSTR: return "ENOSTR"; +#endif +#ifdef ENOSYM + case ENOSYM: return "ENOSYM"; +#endif +#ifdef ENOSYS + case ENOSYS: return "ENOSYS"; +#endif +#ifdef ENOTBLK + case ENOTBLK: return "ENOTBLK"; +#endif +#ifdef ENOTCONN + case ENOTCONN: return "ENOTCONN"; +#endif +#ifdef ENOTDIR + case ENOTDIR: return "ENOTDIR"; +#endif +#if defined(ENOTEMPTY) && (!defined(EEXIST) || (ENOTEMPTY != EEXIST)) + case ENOTEMPTY: return "ENOTEMPTY"; +#endif +#ifdef ENOTNAM + case ENOTNAM: return "ENOTNAM"; +#endif +#ifdef ENOTSOCK + case ENOTSOCK: return "ENOTSOCK"; +#endif +#ifdef ENOTTY + case ENOTTY: return "ENOTTY"; +#endif +#ifdef ENOTUNIQ + case ENOTUNIQ: return "ENOTUNIQ"; +#endif +#ifdef ENXIO + case ENXIO: return "ENXIO"; +#endif +#ifdef EOPNOTSUPP + case EOPNOTSUPP: return "EOPNOTSUPP"; +#endif +#ifdef EPERM + case EPERM: return "EPERM"; +#endif +#ifdef EPFNOSUPPORT + case EPFNOSUPPORT: return "EPFNOSUPPORT"; +#endif +#ifdef EPIPE + case EPIPE: return "EPIPE"; +#endif +#ifdef EPROCLIM + case EPROCLIM: return "EPROCLIM"; +#endif +#ifdef EPROCUNAVAIL + case EPROCUNAVAIL: return "EPROCUNAVAIL"; +#endif +#ifdef EPROGMISMATCH + case EPROGMISMATCH: return "EPROGMISMATCH"; +#endif +#ifdef EPROGUNAVAIL + case EPROGUNAVAIL: return "EPROGUNAVAIL"; +#endif +#ifdef EPROTO + case EPROTO: return "EPROTO"; +#endif +#ifdef EPROTONOSUPPORT + case EPROTONOSUPPORT: return "EPROTONOSUPPORT"; +#endif +#ifdef EPROTOTYPE + case EPROTOTYPE: return "EPROTOTYPE"; +#endif +#ifdef ERANGE + case ERANGE: return "ERANGE"; +#endif +#if defined(EREFUSED) && (!defined(ECONNREFUSED) || (EREFUSED != ECONNREFUSED)) + case EREFUSED: return "EREFUSED"; +#endif +#ifdef EREMCHG + case EREMCHG: return "EREMCHG"; +#endif +#ifdef EREMDEV + case EREMDEV: return "EREMDEV"; +#endif +#ifdef EREMOTE + case EREMOTE: return "EREMOTE"; +#endif +#ifdef EREMOTEIO + case EREMOTEIO: return "EREMOTEIO"; +#endif +#ifdef EREMOTERELEASE + case EREMOTERELEASE: return "EREMOTERELEASE"; +#endif +#ifdef EROFS + case EROFS: return "EROFS"; +#endif +#ifdef ERPCMISMATCH + case ERPCMISMATCH: return "ERPCMISMATCH"; +#endif +#ifdef ERREMOTE + case ERREMOTE: return "ERREMOTE"; +#endif +#ifdef ESHUTDOWN + case ESHUTDOWN: return "ESHUTDOWN"; +#endif +#ifdef ESOCKTNOSUPPORT + case ESOCKTNOSUPPORT: return "ESOCKTNOSUPPORT"; +#endif +#ifdef ESPIPE + case ESPIPE: return "ESPIPE"; +#endif +#ifdef ESRCH + case ESRCH: return "ESRCH"; +#endif +#ifdef ESRMNT + case ESRMNT: return "ESRMNT"; +#endif +#ifdef ESTALE + case ESTALE: return "ESTALE"; +#endif +#ifdef ESUCCESS + case ESUCCESS: return "ESUCCESS"; +#endif +#ifdef ETIME + case ETIME: return "ETIME"; +#endif +#ifdef ETIMEDOUT + case ETIMEDOUT: return "ETIMEDOUT"; +#endif +#ifdef ETOOMANYREFS + case ETOOMANYREFS: return "ETOOMANYREFS"; +#endif +#ifdef ETXTBSY + case ETXTBSY: return "ETXTBSY"; +#endif +#ifdef EUCLEAN + case EUCLEAN: return "EUCLEAN"; +#endif +#ifdef EUNATCH + case EUNATCH: return "EUNATCH"; +#endif +#ifdef EUSERS + case EUSERS: return "EUSERS"; +#endif +#ifdef EVERSION + case EVERSION: return "EVERSION"; +#endif +#if defined(EWOULDBLOCK) && (!defined(EAGAIN) || (EWOULDBLOCK != EAGAIN)) + case EWOULDBLOCK: return "EWOULDBLOCK"; +#endif +#ifdef EXDEV + case EXDEV: return "EXDEV"; +#endif +#ifdef EXFULL + case EXFULL: return "EXFULL"; +#endif + } + return "unknown error"; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SignalId -- + * + * Return a textual identifier for a signal number. + * + * Results: + * This procedure returns a machine-readable textual identifier + * that corresponds to sig. The identifier is the same as the + * #define name in signal.h. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_SignalId(sig) + int sig; /* Number of signal. */ +{ + switch (sig) { +#ifdef SIGABRT + case SIGABRT: return "SIGABRT"; +#endif +#ifdef SIGALRM + case SIGALRM: return "SIGALRM"; +#endif +#ifdef SIGBUS + case SIGBUS: return "SIGBUS"; +#endif +#ifdef SIGCHLD + case SIGCHLD: return "SIGCHLD"; +#endif +#if defined(SIGCLD) && (!defined(SIGCHLD) || (SIGCLD != SIGCHLD)) + case SIGCLD: return "SIGCLD"; +#endif +#ifdef SIGCONT + case SIGCONT: return "SIGCONT"; +#endif +#if defined(SIGEMT) && (!defined(SIGXCPU) || (SIGEMT != SIGXCPU)) + case SIGEMT: return "SIGEMT"; +#endif +#ifdef SIGFPE + case SIGFPE: return "SIGFPE"; +#endif +#ifdef SIGHUP + case SIGHUP: return "SIGHUP"; +#endif +#ifdef SIGILL + case SIGILL: return "SIGILL"; +#endif +#ifdef SIGINT + case SIGINT: return "SIGINT"; +#endif +#ifdef SIGIO + case SIGIO: return "SIGIO"; +#endif +#if defined(SIGIOT) && (!defined(SIGABRT) || (SIGIOT != SIGABRT)) + case SIGIOT: return "SIGIOT"; +#endif +#ifdef SIGKILL + case SIGKILL: return "SIGKILL"; +#endif +#if defined(SIGLOST) && (!defined(SIGIOT) || (SIGLOST != SIGIOT)) && (!defined(SIGURG) || (SIGLOST != SIGURG)) + case SIGLOST: return "SIGLOST"; +#endif +#ifdef SIGPIPE + case SIGPIPE: return "SIGPIPE"; +#endif +#if defined(SIGPOLL) && (!defined(SIGIO) || (SIGPOLL != SIGIO)) + case SIGPOLL: return "SIGPOLL"; +#endif +#ifdef SIGPROF + case SIGPROF: return "SIGPROF"; +#endif +#if defined(SIGPWR) && (!defined(SIGXFSZ) || (SIGPWR != SIGXFSZ)) + case SIGPWR: return "SIGPWR"; +#endif +#ifdef SIGQUIT + case SIGQUIT: return "SIGQUIT"; +#endif +#ifdef SIGSEGV + case SIGSEGV: return "SIGSEGV"; +#endif +#ifdef SIGSTOP + case SIGSTOP: return "SIGSTOP"; +#endif +#ifdef SIGSYS + case SIGSYS: return "SIGSYS"; +#endif +#ifdef SIGTERM + case SIGTERM: return "SIGTERM"; +#endif +#ifdef SIGTRAP + case SIGTRAP: return "SIGTRAP"; +#endif +#ifdef SIGTSTP + case SIGTSTP: return "SIGTSTP"; +#endif +#ifdef SIGTTIN + case SIGTTIN: return "SIGTTIN"; +#endif +#ifdef SIGTTOU + case SIGTTOU: return "SIGTTOU"; +#endif +#if defined(SIGURG) && (!defined(SIGIO) || (SIGURG != SIGIO)) + case SIGURG: return "SIGURG"; +#endif +#if defined(SIGUSR1) && (!defined(SIGIO) || (SIGUSR1 != SIGIO)) + case SIGUSR1: return "SIGUSR1"; +#endif +#if defined(SIGUSR2) && (!defined(SIGURG) || (SIGUSR2 != SIGURG)) + case SIGUSR2: return "SIGUSR2"; +#endif +#ifdef SIGVTALRM + case SIGVTALRM: return "SIGVTALRM"; +#endif +#ifdef SIGWINCH + case SIGWINCH: return "SIGWINCH"; +#endif +#ifdef SIGXCPU + case SIGXCPU: return "SIGXCPU"; +#endif +#ifdef SIGXFSZ + case SIGXFSZ: return "SIGXFSZ"; +#endif + } + return "unknown signal"; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SignalMsg -- + * + * Return a human-readable message describing a signal. + * + * Results: + * This procedure returns a string describing sig that should + * make sense to a human. It may not be easy for a machine + * to parse. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_SignalMsg(sig) + int sig; /* Number of signal. */ +{ + switch (sig) { +#ifdef SIGABRT + case SIGABRT: return "SIGABRT"; +#endif +#ifdef SIGALRM + case SIGALRM: return "alarm clock"; +#endif +#ifdef SIGBUS + case SIGBUS: return "bus error"; +#endif +#ifdef SIGCHLD + case SIGCHLD: return "child status changed"; +#endif +#if defined(SIGCLD) && (!defined(SIGCHLD) || (SIGCLD != SIGCHLD)) + case SIGCLD: return "child status changed"; +#endif +#ifdef SIGCONT + case SIGCONT: return "continue after stop"; +#endif +#if defined(SIGEMT) && (!defined(SIGXCPU) || (SIGEMT != SIGXCPU)) + case SIGEMT: return "EMT instruction"; +#endif +#ifdef SIGFPE + case SIGFPE: return "floating-point exception"; +#endif +#ifdef SIGHUP + case SIGHUP: return "hangup"; +#endif +#ifdef SIGILL + case SIGILL: return "illegal instruction"; +#endif +#ifdef SIGINT + case SIGINT: return "interrupt"; +#endif +#ifdef SIGIO + case SIGIO: return "input/output possible on file"; +#endif +#if defined(SIGIOT) && (!defined(SIGABRT) || (SIGABRT != SIGIOT)) + case SIGIOT: return "IOT instruction"; +#endif +#ifdef SIGKILL + case SIGKILL: return "kill signal"; +#endif +#if defined(SIGLOST) && (!defined(SIGIOT) || (SIGLOST != SIGIOT)) && (!defined(SIGURG) || (SIGLOST != SIGURG)) + case SIGLOST: return "resource lost"; +#endif +#ifdef SIGPIPE + case SIGPIPE: return "write on pipe with no readers"; +#endif +#if defined(SIGPOLL) && (!defined(SIGIO) || (SIGPOLL != SIGIO)) + case SIGPOLL: return "input/output possible on file"; +#endif +#ifdef SIGPROF + case SIGPROF: return "profiling alarm"; +#endif +#if defined(SIGPWR) && (!defined(SIGXFSZ) || (SIGPWR != SIGXFSZ)) + case SIGPWR: return "power-fail restart"; +#endif +#ifdef SIGQUIT + case SIGQUIT: return "quit signal"; +#endif +#ifdef SIGSEGV + case SIGSEGV: return "segmentation violation"; +#endif +#ifdef SIGSTOP + case SIGSTOP: return "stop"; +#endif +#ifdef SIGSYS + case SIGSYS: return "bad argument to system call"; +#endif +#ifdef SIGTERM + case SIGTERM: return "software termination signal"; +#endif +#ifdef SIGTRAP + case SIGTRAP: return "trace trap"; +#endif +#ifdef SIGTSTP + case SIGTSTP: return "stop signal from tty"; +#endif +#ifdef SIGTTIN + case SIGTTIN: return "background tty read"; +#endif +#ifdef SIGTTOU + case SIGTTOU: return "background tty write"; +#endif +#if defined(SIGURG) && (!defined(SIGIO) || (SIGURG != SIGIO)) + case SIGURG: return "urgent I/O condition"; +#endif +#if defined(SIGUSR1) && (!defined(SIGIO) || (SIGUSR1 != SIGIO)) + case SIGUSR1: return "user-defined signal 1"; +#endif +#if defined(SIGUSR2) && (!defined(SIGURG) || (SIGUSR2 != SIGURG)) + case SIGUSR2: return "user-defined signal 2"; +#endif +#ifdef SIGVTALRM + case SIGVTALRM: return "virtual time alarm"; +#endif +#ifdef SIGWINCH + case SIGWINCH: return "window changed"; +#endif +#ifdef SIGXCPU + case SIGXCPU: return "exceeded CPU time limit"; +#endif +#ifdef SIGXFSZ + case SIGXFSZ: return "exceeded file size limit"; +#endif + } + return "unknown signal"; +} diff --git a/vendor/x11iraf/obm/Tcl/tclUnixUtil.c b/vendor/x11iraf/obm/Tcl/tclUnixUtil.c new file mode 100644 index 00000000..9f85dc86 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/tclUnixUtil.c @@ -0,0 +1,1393 @@ +/* + * tclUnixUtil.c -- + * + * This file contains a collection of utility procedures that + * are present in the Tcl's UNIX core but not in the generic + * core. For example, they do file manipulation and process + * manipulation. + * + * Parts of this file are based on code contributed by Karl + * Lehenbauer, Mark Diekhans and Peter da Silva. + * + * Copyright (c) 1991-1993 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. + */ + +#ifndef lint +static char rcsid[] = "$Header: /user6/ouster/tcl/RCS/tclUnixUtil.c,v 1.45 93/10/23 14:52:10 ouster Exp $ SPRITE (Berkeley)"; +#endif /* not lint */ + +#include "tclInt.h" +#include "tclUnix.h" + +/* + * A linked list of the following structures is used to keep track + * of child processes that have been detached but haven't exited + * yet, so we can make sure that they're properly "reaped" (officially + * waited for) and don't lie around as zombies cluttering the + * system. + */ + +typedef struct Detached { + int pid; /* Id of process that's been detached + * but isn't known to have exited. */ + struct Detached *nextPtr; /* Next in list of all detached + * processes. */ +} Detached; + +static Detached *detList = NULL; /* List of all detached proceses. */ + +/* + * The following variables are used to keep track of all the open files + * in the process. These files can be shared across interpreters, so the + * information can't be put in the Interp structure. + */ + +int tclNumFiles = 0; /* Number of entries in tclOpenFiles below. + * 0 means array hasn't been created yet. */ +OpenFile **tclOpenFiles; /* Pointer to malloc-ed array of pointers + * to information about open files. Entry + * N corresponds to the file with fileno N. + * If an entry is NULL then the corresponding + * file isn't open. If tclOpenFiles is NULL + * it means no files have been used, so even + * stdin/stdout/stderr entries haven't been + * setup yet. */ + +/* + * Declarations for local procedures defined in this file: + */ + +static int FileForRedirect _ANSI_ARGS_((Tcl_Interp *interp, + char *spec, int atOk, char *arg, int flags, + char *nextArg, int *skipPtr, int *closePtr)); +static void MakeFileTable _ANSI_ARGS_((Interp *iPtr, int index)); +static void RestoreSignals _ANSI_ARGS_((void)); + +/* + *---------------------------------------------------------------------- + * + * Tcl_EvalFile -- + * + * Read in a file and process the entire file as one gigantic + * Tcl command. + * + * Results: + * A standard Tcl result, which is either the result of executing + * the file or an error indicating why the file couldn't be read. + * + * Side effects: + * Depends on the commands in the file. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_EvalFile(interp, fileName) + Tcl_Interp *interp; /* Interpreter in which to process file. */ + char *fileName; /* Name of file to process. Tilde-substitution + * will be performed on this name. */ +{ + int fileId, result; + struct stat statBuf; + char *cmdBuffer, *oldScriptFile; + Interp *iPtr = (Interp *) interp; + Tcl_DString buffer; + + oldScriptFile = iPtr->scriptFile; + iPtr->scriptFile = fileName; + fileName = Tcl_TildeSubst(interp, fileName, &buffer); + if (fileName == NULL) { + goto error; + } + fileId = open(fileName, O_RDONLY, 0); + if (fileId < 0) { + Tcl_AppendResult(interp, "couldn't read file \"", fileName, + "\": ", Tcl_PosixError(interp), (char *) NULL); + goto error; + } + if (fstat(fileId, &statBuf) == -1) { + Tcl_AppendResult(interp, "couldn't stat file \"", fileName, + "\": ", Tcl_PosixError(interp), (char *) NULL); + close(fileId); + goto error; + } + cmdBuffer = (char *) ckalloc((unsigned) statBuf.st_size+1); + if (read(fileId, cmdBuffer, (size_t) statBuf.st_size) != statBuf.st_size) { + Tcl_AppendResult(interp, "error in reading file \"", fileName, + "\": ", Tcl_PosixError(interp), (char *) NULL); + close(fileId); + ckfree(cmdBuffer); + goto error; + } + if (close(fileId) != 0) { + Tcl_AppendResult(interp, "error closing file \"", fileName, + "\": ", Tcl_PosixError(interp), (char *) NULL); + ckfree(cmdBuffer); + goto error; + } + cmdBuffer[statBuf.st_size] = 0; + result = Tcl_Eval(interp, cmdBuffer); + if (result == TCL_RETURN) { + result = TCL_OK; + } + if (result == TCL_ERROR) { + char msg[200]; + + /* + * Record information telling where the error occurred. + */ + + sprintf(msg, "\n (file \"%.150s\" line %d)", fileName, + interp->errorLine); + Tcl_AddErrorInfo(interp, msg); + } + ckfree(cmdBuffer); + iPtr->scriptFile = oldScriptFile; + Tcl_DStringFree(&buffer); + return result; + + error: + iPtr->scriptFile = oldScriptFile; + Tcl_DStringFree(&buffer); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DetachPids -- + * + * This procedure is called to indicate that one or more child + * processes have been placed in background and will never be + * waited for; they should eventually be reaped by + * Tcl_ReapDetachedProcs. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DetachPids(numPids, pidPtr) + int numPids; /* Number of pids to detach: gives size + * of array pointed to by pidPtr. */ + int *pidPtr; /* Array of pids to detach. */ +{ + register Detached *detPtr; + int i; + + for (i = 0; i < numPids; i++) { + detPtr = (Detached *) ckalloc(sizeof(Detached)); + detPtr->pid = pidPtr[i]; + detPtr->nextPtr = detList; + detList = detPtr; + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ReapDetachedProcs -- + * + * This procedure checks to see if any detached processes have + * exited and, if so, it "reaps" them by officially waiting on + * them. It should be called "occasionally" to make sure that + * all detached processes are eventually reaped. + * + * Results: + * None. + * + * Side effects: + * Processes are waited on, so that they can be reaped by the + * system. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_ReapDetachedProcs() +{ + register Detached *detPtr; + Detached *nextPtr, *prevPtr; + int status, result; + + for (detPtr = detList, prevPtr = NULL; detPtr != NULL; ) { + result = waitpid(detPtr->pid, &status, WNOHANG); + if ((result == 0) || ((result == -1) && (errno != ECHILD))) { + prevPtr = detPtr; + detPtr = detPtr->nextPtr; + continue; + } + nextPtr = detPtr->nextPtr; + if (prevPtr == NULL) { + detList = detPtr->nextPtr; + } else { + prevPtr->nextPtr = detPtr->nextPtr; + } + ckfree((char *) detPtr); + detPtr = nextPtr; + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_CreatePipeline -- + * + * Given an argc/argv array, instantiate a pipeline of processes + * as described by the argv. + * + * Results: + * The return value is a count of the number of new processes + * created, or -1 if an error occurred while creating the pipeline. + * *pidArrayPtr is filled in with the address of a dynamically + * allocated array giving the ids of all of the processes. It + * is up to the caller to free this array when it isn't needed + * anymore. If inPipePtr is non-NULL, *inPipePtr is filled in + * with the file id for the input pipe for the pipeline (if any): + * the caller must eventually close this file. If outPipePtr + * isn't NULL, then *outPipePtr is filled in with the file id + * for the output pipe from the pipeline: the caller must close + * this file. If errFilePtr isn't NULL, then *errFilePtr is filled + * with a file id that may be used to read error output after the + * pipeline completes. + * + * Side effects: + * Processes and pipes are created. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_CreatePipeline(interp, argc, argv, pidArrayPtr, inPipePtr, + outPipePtr, errFilePtr) + Tcl_Interp *interp; /* Interpreter to use for error reporting. */ + int argc; /* Number of entries in argv. */ + char **argv; /* Array of strings describing commands in + * pipeline plus I/O redirection with <, + * <<, >, etc. Argv[argc] must be NULL. */ + int **pidArrayPtr; /* Word at *pidArrayPtr gets filled in with + * address of array of pids for processes + * in pipeline (first pid is first process + * in pipeline). */ + int *inPipePtr; /* If non-NULL, input to the pipeline comes + * from a pipe (unless overridden by + * redirection in the command). The file + * id with which to write to this pipe is + * stored at *inPipePtr. -1 means command + * specified its own input source. */ + int *outPipePtr; /* If non-NULL, output to the pipeline goes + * to a pipe, unless overriden by redirection + * in the command. The file id with which to + * read frome this pipe is stored at + * *outPipePtr. -1 means command specified + * its own output sink. */ + int *errFilePtr; /* If non-NULL, all stderr output from the + * pipeline will go to a temporary file + * created here, and a descriptor to read + * the file will be left at *errFilePtr. + * The file will be removed already, so + * closing this descriptor will be the end + * of the file. If this is NULL, then + * all stderr output goes to our stderr. + * If the pipeline specifies redirection + * then the fill will still be created + * but it will never get any data. */ +{ + int *pidPtr = NULL; /* Points to malloc-ed array holding all + * the pids of child processes. */ + int numPids = 0; /* Actual number of processes that exist + * at *pidPtr right now. */ + int cmdCount; /* Count of number of distinct commands + * found in argc/argv. */ + char *input = NULL; /* If non-null, then this points to a + * string containing input data (specified + * via <<) to be piped to the first process + * in the pipeline. */ + int inputId = -1; /* If >= 0, gives file id to use as input for + * first process in pipeline (specified via + * < or <@). */ + int closeInput = 0; /* If non-zero, then must close inputId + * when cleaning up (zero means the file needs + * to stay open for some other reason). */ + int outputId = -1; /* Writable file id for output from last + * command in pipeline (could be file or pipe). + * -1 means use stdout. */ + int closeOutput = 0; /* Non-zero means must close outputId when + * cleaning up (similar to closeInput). */ + int errorId = -1; /* Writable file id for error output from + * all commands in pipeline. -1 means use + * stderr. */ + int closeError = 0; /* Non-zero means must close errorId when + * cleaning up. */ + int pipeIds[2]; /* File ids for pipe that's being created. */ + int firstArg, lastArg; /* Indexes of first and last arguments in + * current command. */ + int skip; /* Number of arguments to skip (because they + * specify redirection). */ + int maxFd; /* Highest known file descriptor (used to + * close off extraneous file descriptors in + * child process). */ + int lastBar; + char *execName; + int i, j, pid; + char *p; + Tcl_DString buffer; + + if (inPipePtr != NULL) { + *inPipePtr = -1; + } + if (outPipePtr != NULL) { + *outPipePtr = -1; + } + if (errFilePtr != NULL) { + *errFilePtr = -1; + } + pipeIds[0] = pipeIds[1] = -1; + + /* + * First, scan through all the arguments to figure out the structure + * of the pipeline. Process all of the input and output redirection + * arguments and remove them from the argument list in the pipeline. + * Count the number of distinct processes (it's the number of "|" + * arguments plus one) but don't remove the "|" arguments. + */ + + cmdCount = 1; + lastBar = -1; + for (i = 0; i < argc; i++) { + if ((argv[i][0] == '|') && (((argv[i][1] == 0)) + || ((argv[i][1] == '&') && (argv[i][2] == 0)))) { + if ((i == (lastBar+1)) || (i == (argc-1))) { + interp->result = "illegal use of | or |& in command"; + return -1; + } + lastBar = i; + cmdCount++; + continue; + } else if (argv[i][0] == '<') { + if ((inputId >= 0) && closeInput) { + close(inputId); + } + inputId = -1; + skip = 1; + if (argv[i][1] == '<') { + input = argv[i]+2; + if (*input == 0) { + input = argv[i+1]; + if (input == 0) { + Tcl_AppendResult(interp, "can't specify \"", argv[i], + "\" as last word in command", (char *) NULL); + goto error; + } + skip = 2; + } + } else { + input = 0; + inputId = FileForRedirect(interp, argv[i]+1, 1, argv[i], + O_RDONLY, argv[i+1], &skip, &closeInput); + if (inputId < 0) { + goto error; + } + } + } else if (argv[i][0] == '>') { + int append, useForStdErr, useForStdOut, mustClose, fd, atOk, flags; + + skip = atOk = 1; + append = useForStdErr = 0; + useForStdOut = 1; + if (argv[i][1] == '>') { + p = argv[i] + 2; + append = 1; + atOk = 0; + flags = O_WRONLY|O_CREAT; + } else { + p = argv[i] + 1; + flags = O_WRONLY|O_CREAT|O_TRUNC; + } + if (*p == '&') { + useForStdErr = 1; + p++; + } + fd = FileForRedirect(interp, p, atOk, argv[i], flags, argv[i+1], + &skip, &mustClose); + if (fd < 0) { + goto error; + } + if (append) { + lseek(fd, 0L, 2); + } + + /* + * Got the file descriptor. Now use it for standard output, + * standard error, or both, depending on the redirection. + */ + + if (useForStdOut) { + if ((outputId > 0) && closeOutput) { + close(outputId); + } + outputId = fd; + closeOutput = mustClose; + } + if (useForStdErr) { + if ((errorId > 0) && closeError) { + close(errorId); + } + errorId = fd; + closeError = (useForStdOut) ? 0 : mustClose; + } + } else if ((argv[i][0] == '2') && (argv[i][1] == '>')) { + int append, atOk, flags; + + if ((errorId > 0) && closeError) { + close(errorId); + } + skip = 1; + p = argv[i] + 2; + if (*p == '>') { + p++; + append = 1; + atOk = 0; + flags = O_WRONLY|O_CREAT; + } else { + append = 0; + atOk = 1; + flags = O_WRONLY|O_CREAT|O_TRUNC; + } + errorId = FileForRedirect(interp, p, atOk, argv[i], flags, + argv[i+1], &skip, &closeError); + if (errorId < 0) { + goto error; + } + if (append) { + lseek(errorId, 0L, 2); + } + } else { + continue; + } + for (j = i+skip; j < argc; j++) { + argv[j-skip] = argv[j]; + } + argc -= skip; + i -= 1; /* Process next arg from same position. */ + } + if (argc == 0) { + interp->result = "didn't specify command to execute"; + return -1; + } + + if (inputId < 0) { + if (input != NULL) { + char inName[L_tmpnam]; + int length; + + /* + * The input for the first process is immediate data coming from + * Tcl. Create a temporary file for it and put the data into the + * file. + */ + +#ifdef linux + mkstemp(inName); +#else + tmpnam(inName); +#endif + inputId = open(inName, O_RDWR|O_CREAT|O_TRUNC, 0600); + closeInput = 1; + if (inputId < 0) { + Tcl_AppendResult(interp, + "couldn't create input file for command: ", + Tcl_PosixError(interp), (char *) NULL); + goto error; + } + length = strlen(input); + if (write(inputId, input, (size_t) length) != length) { + Tcl_AppendResult(interp, + "couldn't write file input for command: ", + Tcl_PosixError(interp), (char *) NULL); + goto error; + } + if ((lseek(inputId, 0L, 0) == -1) || (unlink(inName) == -1)) { + Tcl_AppendResult(interp, + "couldn't reset or remove input file for command: ", + Tcl_PosixError(interp), (char *) NULL); + goto error; + } + } else if (inPipePtr != NULL) { + /* + * The input for the first process in the pipeline is to + * come from a pipe that can be written from this end. + */ + + if (pipe(pipeIds) != 0) { + Tcl_AppendResult(interp, + "couldn't create input pipe for command: ", + Tcl_PosixError(interp), (char *) NULL); + goto error; + } + inputId = pipeIds[0]; + closeInput = 1; + *inPipePtr = pipeIds[1]; + pipeIds[0] = pipeIds[1] = -1; + } + } + + /* + * Set up a pipe to receive output from the pipeline, if no other + * output sink has been specified. + */ + + if ((outputId < 0) && (outPipePtr != NULL)) { + if (pipe(pipeIds) != 0) { + Tcl_AppendResult(interp, + "couldn't create output pipe: ", + Tcl_PosixError(interp), (char *) NULL); + goto error; + } + outputId = pipeIds[1]; + closeOutput = 1; + *outPipePtr = pipeIds[0]; + pipeIds[0] = pipeIds[1] = -1; + } + + /* + * Set up the standard error output sink for the pipeline, if + * requested. Use a temporary file which is opened, then deleted. + * Could potentially just use pipe, but if it filled up it could + * cause the pipeline to deadlock: we'd be waiting for processes + * to complete before reading stderr, and processes couldn't complete + * because stderr was backed up. + */ + + if (errFilePtr != NULL) { + char errName[L_tmpnam]; + +#ifdef linux + mkstemp(errName); +#else + tmpnam(errName); +#endif + *errFilePtr = open(errName, O_RDONLY|O_CREAT|O_TRUNC, 0600); + if (*errFilePtr < 0) { + errFileError: + Tcl_AppendResult(interp, + "couldn't create error file for command: ", + Tcl_PosixError(interp), (char *) NULL); + goto error; + } + if (errorId < 0) { + errorId = open(errName, O_WRONLY|O_CREAT|O_TRUNC, 0600); + if (errorId < 0) { + goto errFileError; + } + closeError = 1; + } + if (unlink(errName) == -1) { + Tcl_AppendResult(interp, + "couldn't remove error file for command: ", + Tcl_PosixError(interp), (char *) NULL); + goto error; + } + } + + /* + * Find the largest file descriptor used so far, so that we can + * clean up all the extraneous file descriptors in the child + * processes we create. + */ + + maxFd = inputId; + if (outputId > maxFd) { + maxFd = outputId; + } + if (errorId > maxFd) { + maxFd = errorId; + } + if ((inPipePtr != NULL) && (*inPipePtr > maxFd)) { + maxFd = *inPipePtr; + } + if ((outPipePtr != NULL) && (*outPipePtr > maxFd)) { + maxFd = *outPipePtr; + } + if ((errFilePtr != NULL) && (*errFilePtr > maxFd)) { + maxFd = *errFilePtr; + } + + /* + * Scan through the argc array, forking off a process for each + * group of arguments between "|" arguments. + */ + + pidPtr = (int *) ckalloc((unsigned) (cmdCount * sizeof(int))); + for (i = 0; i < numPids; i++) { + pidPtr[i] = -1; + } + Tcl_ReapDetachedProcs(); + for (firstArg = 0; firstArg < argc; numPids++, firstArg = lastArg+1) { + int joinThisError; + int curOutputId; + + joinThisError = 0; + for (lastArg = firstArg; lastArg < argc; lastArg++) { + if (argv[lastArg][0] == '|') { + if (argv[lastArg][1] == 0) { + break; + } + if ((argv[lastArg][1] == '&') && (argv[lastArg][2] == 0)) { + joinThisError = 1; + break; + } + } + } + argv[lastArg] = NULL; + if (lastArg == argc) { + curOutputId = outputId; + } else { + if (pipe(pipeIds) != 0) { + Tcl_AppendResult(interp, "couldn't create pipe: ", + Tcl_PosixError(interp), (char *) NULL); + goto error; + } + curOutputId = pipeIds[1]; + if (pipeIds[0] > maxFd) { + maxFd = pipeIds[0]; + } + if (pipeIds[1] > maxFd) { + maxFd = pipeIds[1]; + } + } + execName = Tcl_TildeSubst(interp, argv[firstArg], &buffer); + pid = fork(); + if (pid == 0) { + char errSpace[200]; + + if (((inputId != -1) && (dup2(inputId, 0) == -1)) + || ((curOutputId != -1) && (dup2(curOutputId, 1) == -1)) + || (joinThisError && (dup2(1, 2) == -1)) + || (!joinThisError && (errorId != -1) + && (dup2(errorId, 2) == -1))) { + char *err; + err = "forked process couldn't set up input/output\n"; + write(errorId < 0 ? 2 : errorId, err, (size_t) strlen(err)); + _exit(1); + } + for (i = 3; i <= maxFd; i++) { + close(i); + } + RestoreSignals(); + execvp(execName, &argv[firstArg]); + sprintf(errSpace, "couldn't find \"%.150s\" to execute\n", + argv[firstArg]); + write(2, errSpace, (size_t) strlen(errSpace)); + _exit(1); + } + Tcl_DStringFree(&buffer); + if (pid == -1) { + Tcl_AppendResult(interp, "couldn't fork child process: ", + Tcl_PosixError(interp), (char *) NULL); + goto error; + } + pidPtr[numPids] = pid; + + /* + * Close off our copies of file descriptors that were set up for + * this child, then set up the input for the next child. + */ + + if ((inputId != -1) && closeInput) { + close(inputId); + } + if ((curOutputId != -1) && (curOutputId != outputId)) { + close(curOutputId); + } + inputId = pipeIds[0]; + closeInput = 1; + pipeIds[0] = pipeIds[1] = -1; + } + *pidArrayPtr = pidPtr; + + /* + * All done. Cleanup open files lying around and then return. + */ + +cleanup: + if ((inputId != -1) && closeInput) { + close(inputId); + } + if ((outputId != -1) && closeOutput) { + close(outputId); + } + if ((errorId != -1) && closeError) { + close(errorId); + } + return numPids; + + /* + * An error occurred. There could have been extra files open, such + * as pipes between children. Clean them all up. Detach any child + * processes that have been created. + */ + + error: + if ((inPipePtr != NULL) && (*inPipePtr != -1)) { + close(*inPipePtr); + *inPipePtr = -1; + } + if ((outPipePtr != NULL) && (*outPipePtr != -1)) { + close(*outPipePtr); + *outPipePtr = -1; + } + if ((errFilePtr != NULL) && (*errFilePtr != -1)) { + close(*errFilePtr); + *errFilePtr = -1; + } + if (pipeIds[0] != -1) { + close(pipeIds[0]); + } + if (pipeIds[1] != -1) { + close(pipeIds[1]); + } + if (pidPtr != NULL) { + for (i = 0; i < numPids; i++) { + if (pidPtr[i] != -1) { + Tcl_DetachPids(1, &pidPtr[i]); + } + } + ckfree((char *) pidPtr); + } + numPids = -1; + goto cleanup; +} + +/* + *---------------------------------------------------------------------- + * + * FileForRedirect -- + * + * This procedure does much of the work of parsing redirection + * operators. It handles "@" if specified and allowed, and a file + * name, and opens the file if necessary. + * + * Results: + * The return value is the descriptor number for the file. If an + * error occurs then -1 is returned and an error message is left + * in interp->result. Several arguments are side-effected; see + * the argument list below for details. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +FileForRedirect(interp, spec, atOk, arg, flags, nextArg, skipPtr, closePtr) + Tcl_Interp *interp; /* Intepreter to use for error + * reporting. */ + register char *spec; /* Points to character just after + * redirection character. */ + int atOk; /* Non-zero means '@' notation is + * OK, zero means it isn't. */ + char *arg; /* Pointer to entire argument + * containing spec: used for error + * reporting. */ + int flags; /* Flags to use for opening file. */ + char *nextArg; /* Next argument in argc/argv + * array, if needed for file name. + * May be NULL. */ + int *skipPtr; /* This value is incremented if + * nextArg is used for redirection + * spec. */ + int *closePtr; /* This value is set to 1 if the file + * that's returned must be closed, 0 + * if it was specified with "@" so + * it must be left open. */ +{ + int writing = (flags & O_WRONLY); + FILE *f; + int fd; + + if (atOk && (*spec == '@')) { + spec++; + if (*spec == 0) { + spec = nextArg; + if (spec == NULL) { + goto badLastArg; + } + *skipPtr += 1; + } + if (Tcl_GetOpenFile(interp, spec, writing, 1, &f) != TCL_OK) { + return -1; + } + *closePtr = 0; + fd = fileno(f); + } else { + if (*spec == 0) { + spec = nextArg; + if (spec == NULL) { + goto badLastArg; + } + *skipPtr += 1; + } + fd = open(spec, flags, 0666); + if (fd < 0) { + Tcl_AppendResult(interp, "couldn't ", + (writing) ? "write" : "read", " file \"", spec, "\": ", + Tcl_PosixError(interp), (char *) NULL); + return -1; + } + *closePtr = 1; + } + return fd; + + badLastArg: + Tcl_AppendResult(interp, "can't specify \"", arg, + "\" as last word in command", (char *) NULL); + return -1; +} + +/* + *---------------------------------------------------------------------- + * + * RestoreSignals -- + * + * This procedure is invoked in a forked child process just before + * exec-ing a new program to restore all signals to their default + * settings. + * + * Results: + * None. + * + * Side effects: + * Signal settings get changed. + * + *---------------------------------------------------------------------- + */ + +static void +RestoreSignals() +{ +#ifdef SIGABRT + signal(SIGABRT, SIG_DFL); +#endif +#ifdef SIGALRM + signal(SIGALRM, SIG_DFL); +#endif +#ifdef SIGFPE + signal(SIGFPE, SIG_DFL); +#endif +#ifdef SIGHUP + signal(SIGHUP, SIG_DFL); +#endif +#ifdef SIGILL + signal(SIGILL, SIG_DFL); +#endif +#ifdef SIGINT + signal(SIGINT, SIG_DFL); +#endif +#ifdef SIGPIPE + signal(SIGPIPE, SIG_DFL); +#endif +#ifdef SIGQUIT + signal(SIGQUIT, SIG_DFL); +#endif +#ifdef SIGSEGV + signal(SIGSEGV, SIG_DFL); +#endif +#ifdef SIGTERM + signal(SIGTERM, SIG_DFL); +#endif +#ifdef SIGUSR1 + signal(SIGUSR1, SIG_DFL); +#endif +#ifdef SIGUSR2 + signal(SIGUSR2, SIG_DFL); +#endif +#ifdef SIGCHLD + signal(SIGCHLD, SIG_DFL); +#endif +#ifdef SIGCONT + signal(SIGCONT, SIG_DFL); +#endif +#ifdef SIGTSTP + signal(SIGTSTP, SIG_DFL); +#endif +#ifdef SIGTTIN + signal(SIGTTIN, SIG_DFL); +#endif +#ifdef SIGTTOU + signal(SIGTTOU, SIG_DFL); +#endif +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_PosixError -- + * + * This procedure is typically called after UNIX kernel calls + * return errors. It stores machine-readable information about + * the error in $errorCode returns an information string for + * the caller's use. + * + * Results: + * The return value is a human-readable string describing the + * error, as returned by strerror. + * + * Side effects: + * The global variable $errorCode is reset. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_PosixError(interp) + Tcl_Interp *interp; /* Interpreter whose $errorCode variable + * is to be changed. */ +{ + char *id, *msg; + + id = Tcl_ErrnoId(); + msg = strerror(errno); + Tcl_SetErrorCode(interp, "POSIX", id, msg, (char *) NULL); + return msg; +} + +/* + *---------------------------------------------------------------------- + * + * MakeFileTable -- + * + * Create or enlarge the file table for the interpreter, so that + * there is room for a given index. + * + * Results: + * None. + * + * Side effects: + * The file table for iPtr will be created if it doesn't exist + * (and entries will be added for stdin, stdout, and stderr). + * If it already exists, then it will be grown if necessary. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static void +MakeFileTable(iPtr, index) + Interp *iPtr; /* Interpreter whose table of files is + * to be manipulated. */ + int index; /* Make sure table is large enough to + * hold at least this index. */ +{ + /* + * If the table doesn't even exist, then create it and initialize + * entries for standard files. + */ + + if (tclNumFiles == 0) { + OpenFile *oFilePtr; + int i; + + if (index < 2) { + tclNumFiles = 3; + } else { + tclNumFiles = index+1; + } + tclOpenFiles = (OpenFile **) ckalloc((unsigned) + ((tclNumFiles)*sizeof(OpenFile *))); + for (i = tclNumFiles-1; i >= 0; i--) { + tclOpenFiles[i] = NULL; + } + + oFilePtr = (OpenFile *) ckalloc(sizeof(OpenFile)); + oFilePtr->f = stdin; + oFilePtr->f2 = NULL; + oFilePtr->permissions = TCL_FILE_READABLE; + oFilePtr->numPids = 0; + oFilePtr->pidPtr = NULL; + oFilePtr->errorId = -1; + tclOpenFiles[0] = oFilePtr; + + oFilePtr = (OpenFile *) ckalloc(sizeof(OpenFile)); + oFilePtr->f = stdout; + oFilePtr->f2 = NULL; + oFilePtr->permissions = TCL_FILE_WRITABLE; + oFilePtr->numPids = 0; + oFilePtr->pidPtr = NULL; + oFilePtr->errorId = -1; + tclOpenFiles[1] = oFilePtr; + + oFilePtr = (OpenFile *) ckalloc(sizeof(OpenFile)); + oFilePtr->f = stderr; + oFilePtr->f2 = NULL; + oFilePtr->permissions = TCL_FILE_WRITABLE; + oFilePtr->numPids = 0; + oFilePtr->pidPtr = NULL; + oFilePtr->errorId = -1; + tclOpenFiles[2] = oFilePtr; + } else if (index >= tclNumFiles) { + int newSize; + OpenFile **newPtrArray; + int i; + + newSize = index+1; + newPtrArray = (OpenFile **) ckalloc((unsigned) + ((newSize)*sizeof(OpenFile *))); + memcpy((VOID *) newPtrArray, (VOID *) tclOpenFiles, + tclNumFiles*sizeof(OpenFile *)); + for (i = tclNumFiles; i < newSize; i++) { + newPtrArray[i] = NULL; + } + ckfree((char *) tclOpenFiles); + tclNumFiles = newSize; + tclOpenFiles = newPtrArray; + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_EnterFile -- + * + * This procedure is used to enter an already-open file into the + * file table for an interpreter so that the file can be read + * and written with Tcl commands. + * + * Results: + * There is no return value, but interp->result is set to + * hold Tcl's id for the open file, such as "file4". + * + * Side effects: + * "File" is added to the files accessible from interp. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_EnterFile(interp, file, permissions) + Tcl_Interp *interp; /* Interpreter in which to make file + * available. */ + FILE *file; /* File to make available in interp. */ + int permissions; /* Ops that may be done on file: OR-ed + * combinination of TCL_FILE_READABLE and + * TCL_FILE_WRITABLE. */ +{ + Interp *iPtr = (Interp *) interp; + int fd; + register OpenFile *oFilePtr; + + fd = fileno(file); + if (fd >= tclNumFiles) { + MakeFileTable(iPtr, fd); + } + oFilePtr = tclOpenFiles[fd]; + + /* + * It's possible that there already appears to be a file open in + * the slot. This could happen, for example, if the application + * closes a file behind our back so that we don't have a chance + * to clean up. This is probably a bad idea, but if it happens + * just discard the information in the old record (hopefully the + * application is smart enough to have really cleaned everything + * up right). + */ + + if (oFilePtr == NULL) { + oFilePtr = (OpenFile *) ckalloc(sizeof(OpenFile)); + tclOpenFiles[fd] = oFilePtr; + } + oFilePtr->f = file; + oFilePtr->f2 = NULL; + oFilePtr->permissions = permissions; + oFilePtr->numPids = 0; + oFilePtr->pidPtr = NULL; + oFilePtr->errorId = -1; + if (fd <= 2) { + if (fd == 0) { + interp->result = "stdin"; + } else if (fd == 1) { + interp->result = "stdout"; + } else { + interp->result = "stderr"; + } + } else { + sprintf(interp->result, "file%d", fd); + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetOpenFile -- + * + * Given a string identifier for an open file, find the corresponding + * open file structure, if there is one. + * + * Results: + * A standard Tcl return value. If the open file is successfully + * located and meets any usage check requested by checkUsage, TCL_OK + * is returned and *filePtr is modified to hold a pointer to its + * FILE structure. If an error occurs then TCL_ERROR is returned + * and interp->result contains an error message. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_GetOpenFile(interp, string, forWriting, checkUsage, filePtr) + Tcl_Interp *interp; /* Interpreter in which to find file. */ + char *string; /* String that identifies file. */ + int forWriting; /* 1 means the file is going to be used + * for writing, 0 means for reading. */ + int checkUsage; /* 1 means verify that the file was opened + * in a mode that allows the access specified + * by "forWriting". */ + FILE **filePtr; /* Store pointer to FILE structure here. */ +{ + OpenFile *oFilePtr; + int fd = 0; /* Initial value needed only to stop compiler + * warnings. */ + Interp *iPtr = (Interp *) interp; + + if ((string[0] == 'f') && (string[1] == 'i') && (string[2] == 'l') + & (string[3] == 'e')) { + char *end; + + fd = strtoul(string+4, &end, 10); + if ((end == string+4) || (*end != 0)) { + goto badId; + } + } else if ((string[0] == 's') && (string[1] == 't') + && (string[2] == 'd')) { + if (strcmp(string+3, "in") == 0) { + fd = 0; + } else if (strcmp(string+3, "out") == 0) { + fd = 1; + } else if (strcmp(string+3, "err") == 0) { + fd = 2; + } else { + goto badId; + } + } else { + badId: + Tcl_AppendResult(interp, "bad file identifier \"", string, + "\"", (char *) NULL); + return TCL_ERROR; + } + + if (fd >= tclNumFiles) { + if ((tclNumFiles == 0) && (fd <= 2)) { + MakeFileTable(iPtr, fd); + } else { + notOpen: + Tcl_AppendResult(interp, "file \"", string, "\" isn't open", + (char *) NULL); + return TCL_ERROR; + } + } + oFilePtr = tclOpenFiles[fd]; + if (oFilePtr == NULL) { + goto notOpen; + } + if (forWriting) { + if (checkUsage && !(oFilePtr->permissions & TCL_FILE_WRITABLE)) { + Tcl_AppendResult(interp, "\"", string, + "\" wasn't opened for writing", (char *) NULL); + return TCL_ERROR; + } + if (oFilePtr->f2 != NULL) { + *filePtr = oFilePtr->f2; + } else { + *filePtr = oFilePtr->f; + } + } else { + if (checkUsage && !(oFilePtr->permissions & TCL_FILE_READABLE)) { + Tcl_AppendResult(interp, "\"", string, + "\" wasn't opened for reading", (char *) NULL); + return TCL_ERROR; + } + *filePtr = oFilePtr->f; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_FilePermissions -- + * + * Given a FILE * pointer, return the read/write permissions + * associated with the open file. + * + * Results: + * If file is currently open, the return value is an OR-ed + * combination of TCL_FILE_READABLE and TCL_FILE_WRITABLE, + * which indicates the operations permitted on the open file. + * If the file isn't open then the return value is -1. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_FilePermissions(file) + FILE *file; /* File for which permissions are wanted. */ +{ + register OpenFile *oFilePtr; + int i, fd; + + /* + * First try the entry in tclOpenFiles given by the file descriptor + * for the file. If that doesn't match then search all the entries + * in tclOpenFiles. + */ + + if (file != NULL) { + fd = fileno(file); + if (fd < tclNumFiles) { + oFilePtr = tclOpenFiles[fd]; + if ((oFilePtr != NULL) && (oFilePtr->f == file)) { + return oFilePtr->permissions; + } + } + } + for (i = 0; i < tclNumFiles; i++) { + oFilePtr = tclOpenFiles[i]; + if (oFilePtr == NULL) { + continue; + } + if ((oFilePtr->f == file) || (oFilePtr->f2 == file)) { + return oFilePtr->permissions; + } + } + return -1; +} + +/* + *---------------------------------------------------------------------- + * + * TclOpen, etc. -- + * + * Below are a bunch of procedures that are used by Tcl instead + * of system calls. Each of the procedures executes the + * corresponding system call and retries automatically + * if the system call was interrupted by a signal. + * + * Results: + * Whatever the system call would normally return. + * + * Side effects: + * Whatever the system call would normally do. + * + * NOTE: + * This should be the last page of this file, since it undefines + * the macros that redirect read etc. to the procedures below. + * + *---------------------------------------------------------------------- + */ + +#undef open +int +TclOpen(path, oflag, mode) + char *path; + int oflag; + int mode; +{ + int result; + while (1) { + result = open(path, oflag, mode); + if ((result != -1) || (errno != EINTR)) { + return result; + } + } +} + +#undef read +int +TclRead(fd, buf, numBytes) + int fd; + VOID *buf; + size_t numBytes; +{ + int result; + while (1) { + result = read(fd, buf, (size_t) numBytes); + if ((result != -1) || (errno != EINTR)) { + return result; + } + } +} + +#undef waitpid +extern pid_t waitpid _ANSI_ARGS_((pid_t pid, int *stat_loc, int options)); + +/* + * Note: the #ifdef below is needed to avoid compiler errors on systems + * that have ANSI compilers and also define pid_t to be short. The + * problem is a complex one having to do with argument type promotion. + */ + +#ifdef _USING_PROTOTYPES_ +int +TclWaitpid _ANSI_ARGS_((pid_t pid, int *statPtr, int options)) +#else +int +TclWaitpid(pid, statPtr, options) + pid_t pid; + int *statPtr; + int options; +#endif /* _USING_PROTOTYPES_ */ +{ + int result; + while (1) { + result = waitpid(pid, statPtr, options); + if ((result != -1) || (errno != EINTR)) { + return result; + } + } +} + +#undef write +int +TclWrite(fd, buf, numBytes) + int fd; + VOID *buf; + size_t numBytes; +{ + int result; + while (1) { + result = write(fd, buf, (size_t) numBytes); + if ((result != -1) || (errno != EINTR)) { + return result; + } + } +} diff --git a/vendor/x11iraf/obm/Tcl/tclUtil.c b/vendor/x11iraf/obm/Tcl/tclUtil.c new file mode 100644 index 00000000..5c3905a9 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/tclUtil.c @@ -0,0 +1,1998 @@ +/* + * tclUtil.c -- + * + * This file contains utility procedures that are used by many Tcl + * commands. + * + * Copyright (c) 1987-1993 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. + */ + +#ifndef lint +static char rcsid[] = "$Header: /user6/ouster/tcl/RCS/tclUtil.c,v 1.84 93/10/11 09:18:49 ouster Exp $ SPRITE (Berkeley)"; +#endif + +#include "tclInt.h" + +/* + * The following values are used in the flags returned by Tcl_ScanElement + * and used by Tcl_ConvertElement. The value TCL_DONT_USE_BRACES is also + * defined in tcl.h; make sure its value doesn't overlap with any of the + * values below. + * + * TCL_DONT_USE_BRACES - 1 means the string mustn't be enclosed in + * braces (e.g. it contains unmatched braces, + * or ends in a backslash character, or user + * just doesn't want braces); handle all + * special characters by adding backslashes. + * USE_BRACES - 1 means the string contains a special + * character that can be handled simply by + * enclosing the entire argument in braces. + * BRACES_UNMATCHED - 1 means that braces aren't properly matched + * in the argument. + */ + +#define USE_BRACES 2 +#define BRACES_UNMATCHED 4 + +/* + * The variable below is set to NULL before invoking regexp functions + * and checked after those functions. If an error occurred then TclRegError + * will set the variable to point to a (static) error message. This + * mechanism unfortunately does not support multi-threading, but then + * neither does the rest of the regexp facilities. + */ + +char *tclRegexpError = NULL; + +/* + * Function prototypes for local procedures in this file: + */ + +static void SetupAppendBuffer _ANSI_ARGS_((Interp *iPtr, + int newSpace)); + +/* + *---------------------------------------------------------------------- + * + * TclFindElement -- + * + * Given a pointer into a Tcl list, locate the first (or next) + * element in the list. + * + * Results: + * The return value is normally TCL_OK, which means that the + * element was successfully located. If TCL_ERROR is returned + * it means that list didn't have proper list structure; + * interp->result contains a more detailed error message. + * + * If TCL_OK is returned, then *elementPtr will be set to point + * to the first element of list, and *nextPtr will be set to point + * to the character just after any white space following the last + * character that's part of the element. If this is the last argument + * in the list, then *nextPtr will point to the NULL character at the + * end of list. If sizePtr is non-NULL, *sizePtr is filled in with + * the number of characters in the element. If the element is in + * braces, then *elementPtr will point to the character after the + * opening brace and *sizePtr will not include either of the braces. + * If there isn't an element in the list, *sizePtr will be zero, and + * both *elementPtr and *termPtr will refer to the null character at + * the end of list. Note: this procedure does NOT collapse backslash + * sequences. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclFindElement(interp, list, elementPtr, nextPtr, sizePtr, bracePtr) + Tcl_Interp *interp; /* Interpreter to use for error reporting. */ + register char *list; /* String containing Tcl list with zero + * or more elements (possibly in braces). */ + char **elementPtr; /* Fill in with location of first significant + * character in first element of list. */ + char **nextPtr; /* Fill in with location of character just + * after all white space following end of + * argument (i.e. next argument or end of + * list). */ + int *sizePtr; /* If non-zero, fill in with size of + * element. */ + int *bracePtr; /* If non-zero fill in with non-zero/zero + * to indicate that arg was/wasn't + * in braces. */ +{ + register char *p; + int openBraces = 0; + int inQuotes = 0; + int size; + + /* + * Skim off leading white space and check for an opening brace or + * quote. Note: use of "isascii" below and elsewhere in this + * procedure is a temporary hack (7/27/90) because Mx uses characters + * with the high-order bit set for some things. This should probably + * be changed back eventually, or all of Tcl should call isascii. + */ + + while (isspace(UCHAR(*list))) { + list++; + } + if (*list == '{') { + openBraces = 1; + list++; + } else if (*list == '"') { + inQuotes = 1; + list++; + } + if (bracePtr != 0) { + *bracePtr = openBraces; + } + p = list; + + /* + * Find the end of the element (either a space or a 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) { + char *p2; + + size = p - list; + p++; + if (isspace(UCHAR(*p)) || (*p == 0)) { + goto done; + } + for (p2 = p; (*p2 != 0) && (!isspace(UCHAR(*p2))) + && (p2 < p+20); p2++) { + /* null body */ + } + Tcl_ResetResult(interp); + sprintf(interp->result, + "list element in braces followed by \"%.*s\" instead of space", + p2-p, p); + return TCL_ERROR; + } else if (openBraces != 0) { + openBraces--; + } + break; + + /* + * Backslash: skip over everything up to the end of the + * backslash sequence. + */ + + case '\\': { + int size; + + (void) Tcl_Backslash(p, &size); + p += size - 1; + 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) { + size = p - list; + goto done; + } + break; + + /* + * Double-quote: if element is in quotes then terminate it. + */ + + case '"': + if (inQuotes) { + char *p2; + + size = p-list; + p++; + if (isspace(UCHAR(*p)) || (*p == 0)) { + goto done; + } + for (p2 = p; (*p2 != 0) && (!isspace(UCHAR(*p2))) + && (p2 < p+20); p2++) { + /* null body */ + } + Tcl_ResetResult(interp); + sprintf(interp->result, + "list element in quotes followed by \"%.*s\" %s", + p2-p, p, "instead of space"); + return TCL_ERROR; + } + break; + + /* + * End of list: terminate element. + */ + + case 0: + if (openBraces != 0) { + Tcl_SetResult(interp, "unmatched open brace in list", + TCL_STATIC); + return TCL_ERROR; + } else if (inQuotes) { + Tcl_SetResult(interp, "unmatched open quote in list", + TCL_STATIC); + return TCL_ERROR; + } + size = p - list; + goto done; + + } + p++; + } + + done: + while (isspace(UCHAR(*p))) { + p++; + } + *elementPtr = list; + *nextPtr = p; + if (sizePtr != 0) { + *sizePtr = size; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclCopyAndCollapse -- + * + * Copy a string and eliminate any backslashes that aren't in braces. + * + * Results: + * There is no return value. Count chars. get copied from src + * to dst. Along the way, if backslash sequences are found outside + * braces, the backslashes are eliminated in the copy. + * After scanning count chars. from source, a null character is + * placed at the end of dst. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +TclCopyAndCollapse(count, src, dst) + int count; /* Total number of characters to copy + * from src. */ + register char *src; /* Copy from here... */ + register char *dst; /* ... to here. */ +{ + register char c; + int numRead; + + for (c = *src; count > 0; src++, c = *src, count--) { + if (c == '\\') { + *dst = Tcl_Backslash(src, &numRead); + dst++; + src += numRead-1; + count -= numRead-1; + } else { + *dst = c; + dst++; + } + } + *dst = 0; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SplitList -- + * + * Splits a list up into its constituent fields. + * + * Results + * The return value is normally TCL_OK, which means that + * the list was successfully split up. If TCL_ERROR is + * returned, it means that "list" didn't have proper list + * structure; interp->result will contain a more detailed + * error message. + * + * *argvPtr will be filled in with the address of an array + * whose elements point to the elements of list, in order. + * *argcPtr will get filled in with the number of valid elements + * in the array. A single block of memory is dynamically allocated + * to hold both the argv array and a copy of the list (with + * backslashes and braces removed in the standard way). + * The caller must eventually free this memory by calling free() + * on *argvPtr. Note: *argvPtr and *argcPtr are only modified + * if the procedure returns normally. + * + * Side effects: + * Memory is allocated. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_SplitList(interp, list, argcPtr, argvPtr) + Tcl_Interp *interp; /* Interpreter to use for error reporting. */ + char *list; /* Pointer to string with list structure. */ + int *argcPtr; /* Pointer to location to fill in with + * the number of elements in the list. */ + char ***argvPtr; /* Pointer to place to store pointer to array + * of pointers to list elements. */ +{ + char **argv; + register char *p; + int size, i, result, elSize, brace; + char *element; + + /* + * Figure out how much space to allocate. There must be enough + * space for both the array of pointers and also for a copy of + * the list. To estimate the number of pointers needed, count + * the number of space characters in the list. + */ + + for (size = 1, p = list; *p != 0; p++) { + if (isspace(UCHAR(*p))) { + size++; + } + } + size++; /* Leave space for final NULL pointer. */ + argv = (char **) ckalloc((unsigned) + ((size * sizeof(char *)) + (p - list) + 1)); + for (i = 0, p = ((char *) argv) + size*sizeof(char *); + *list != 0; i++) { + result = TclFindElement(interp, list, &element, &list, &elSize, &brace); + if (result != TCL_OK) { + ckfree((char *) argv); + return result; + } + if (*element == 0) { + break; + } + if (i >= size) { + ckfree((char *) argv); + Tcl_SetResult(interp, "internal error in Tcl_SplitList", + TCL_STATIC); + return TCL_ERROR; + } + argv[i] = p; + if (brace) { + strncpy(p, element, elSize); + p += elSize; + *p = 0; + p++; + } else { + TclCopyAndCollapse(elSize, element, p); + p += elSize+1; + } + } + + argv[i] = NULL; + *argvPtr = argv; + *argcPtr = i; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ScanElement -- + * + * This procedure is a companion procedure to Tcl_ConvertElement. + * It scans a string to see what needs to be done to it (e.g. + * add backslashes or enclosing braces) to make the string into + * a valid Tcl list element. + * + * Results: + * The return value is an overestimate of the number of characters + * that will be needed by Tcl_ConvertElement to produce a valid + * list element from string. The word at *flagPtr is filled in + * with a value needed by Tcl_ConvertElement when doing the actual + * conversion. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_ScanElement(string, flagPtr) + char *string; /* String to convert to Tcl list element. */ + int *flagPtr; /* Where to store information to guide + * Tcl_ConvertElement. */ +{ + int flags, nestingLevel; + register char *p; + + /* + * This procedure and Tcl_ConvertElement together do two things: + * + * 1. They produce a proper list, one that will yield back the + * argument strings when evaluated or when disassembled with + * Tcl_SplitList. This is the most important thing. + * + * 2. They try to produce legible output, which means minimizing the + * use of backslashes (using braces instead). However, there are + * some situations where backslashes must be used (e.g. an element + * like "{abc": the leading brace will have to be backslashed. For + * each element, one of three things must be done: + * + * (a) Use the element as-is (it doesn't contain anything special + * characters). This is the most desirable option. + * + * (b) Enclose the element in braces, but leave the contents alone. + * This happens if the element contains embedded space, or if it + * contains characters with special interpretation ($, [, ;, or \), + * or if it starts with a brace or double-quote, or if there are + * no characters in the element. + * + * (c) Don't enclose the element in braces, but add backslashes to + * prevent special interpretation of special characters. This is a + * last resort used when the argument would normally fall under case + * (b) but contains unmatched braces. It also occurs if the last + * character of the argument is a backslash or if the element contains + * a backslash followed by newline. + * + * The procedure figures out how many bytes will be needed to store + * the result (actually, it overestimates). It also collects information + * about the element in the form of a flags word. + */ + + nestingLevel = 0; + flags = 0; + if (string == NULL) { + string = ""; + } + p = string; + if ((*p == '{') || (*p == '"') || (*p == 0)) { + flags |= USE_BRACES; + } + for ( ; *p != 0; p++) { + switch (*p) { + case '{': + nestingLevel++; + break; + case '}': + nestingLevel--; + if (nestingLevel < 0) { + flags |= TCL_DONT_USE_BRACES|BRACES_UNMATCHED; + } + break; + case '[': + case '$': + case ';': + case ' ': + case '\f': + case '\n': + case '\r': + case '\t': + case '\v': + flags |= USE_BRACES; + break; + case '\\': + if ((p[1] == 0) || (p[1] == '\n')) { + flags = TCL_DONT_USE_BRACES; + } else { + int size; + + (void) Tcl_Backslash(p, &size); + p += size-1; + flags |= USE_BRACES; + } + break; + } + } + if (nestingLevel != 0) { + flags = TCL_DONT_USE_BRACES | BRACES_UNMATCHED; + } + *flagPtr = flags; + + /* + * Allow enough space to backslash every character plus leave + * two spaces for braces. + */ + + return 2*(p-string) + 2; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ConvertElement -- + * + * This is a companion procedure to Tcl_ScanElement. Given the + * information produced by Tcl_ScanElement, this procedure converts + * a string to a list element equal to that string. + * + * Results: + * Information is copied to *dst in the form of a list element + * identical to src (i.e. if Tcl_SplitList is applied to dst it + * will produce a string identical to src). The return value is + * a count of the number of characters copied (not including the + * terminating NULL character). + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_ConvertElement(src, dst, flags) + register char *src; /* Source information for list element. */ + char *dst; /* Place to put list-ified element. */ + int flags; /* Flags produced by Tcl_ScanElement. */ +{ + register char *p = dst; + + /* + * See the comment block at the beginning of the Tcl_ScanElement + * code for details of how this works. + */ + + if (src == NULL) { + src = ""; + } + if ((flags & USE_BRACES) && !(flags & TCL_DONT_USE_BRACES)) { + *p = '{'; + p++; + for ( ; *src != 0; src++, p++) { + *p = *src; + } + *p = '}'; + p++; + } else if (*src == 0) { + /* + * If string is empty but can't use braces, then use special + * backslash sequence that maps to empty string. + */ + + p[0] = '\\'; + p[1] = '0'; + p += 2; + } else { + if (*src == '{') { + /* + * Can't have a leading brace unless the whole element is + * enclosed in braces. Add a backslash before the brace. + * Furthermore, this may destroy the balance between open + * and close braces, so set BRACES_UNMATCHED. + */ + + p[0] = '\\'; + p[1] = '{'; + p += 2; + src++; + flags |= BRACES_UNMATCHED; + } + for (; *src != 0 ; src++) { + switch (*src) { + case ']': + case '[': + case '$': + case ';': + case ' ': + case '\\': + case '"': + *p = '\\'; + p++; + break; + case '{': + case '}': + /* + * It may not seem necessary to backslash braces, but + * it is. The reason for this is that the resulting + * list element may actually be an element of a sub-list + * enclosed in braces (e.g. if Tcl_DStringStartSublist + * has been invoked), so there may be a brace mismatch + * if the braces aren't backslashed. + */ + + if (flags & BRACES_UNMATCHED) { + *p = '\\'; + p++; + } + break; + case '\f': + *p = '\\'; + p++; + *p = 'f'; + p++; + continue; + case '\n': + *p = '\\'; + p++; + *p = 'n'; + p++; + continue; + case '\r': + *p = '\\'; + p++; + *p = 'r'; + p++; + continue; + case '\t': + *p = '\\'; + p++; + *p = 't'; + p++; + continue; + case '\v': + *p = '\\'; + p++; + *p = 'v'; + p++; + continue; + } + *p = *src; + p++; + } + } + *p = '\0'; + return p-dst; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_Merge -- + * + * Given a collection of strings, merge them together into a + * single string that has proper Tcl list structured (i.e. + * Tcl_SplitList may be used to retrieve strings equal to the + * original elements, and Tcl_Eval will parse the string back + * into its original elements). + * + * Results: + * The return value is the address of a dynamically-allocated + * string containing the merged list. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_Merge(argc, argv) + int argc; /* How many strings to merge. */ + char **argv; /* Array of string values. */ +{ +# define LOCAL_SIZE 20 + int localFlags[LOCAL_SIZE], *flagPtr; + int numChars; + char *result; + register char *dst; + int i; + + /* + * Pass 1: estimate space, gather flags. + */ + + if (argc <= LOCAL_SIZE) { + flagPtr = localFlags; + } else { + flagPtr = (int *) ckalloc((unsigned) argc*sizeof(int)); + } + numChars = 1; + for (i = 0; i < argc; i++) { + numChars += Tcl_ScanElement(argv[i], &flagPtr[i]) + 1; + } + + /* + * Pass two: copy into the result area. + */ + + result = (char *) ckalloc((unsigned) numChars); + dst = result; + for (i = 0; i < argc; i++) { + numChars = Tcl_ConvertElement(argv[i], dst, flagPtr[i]); + dst += numChars; + *dst = ' '; + dst++; + } + if (dst == result) { + *dst = 0; + } else { + dst[-1] = 0; + } + + if (flagPtr != localFlags) { + ckfree((char *) flagPtr); + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_Concat -- + * + * Concatenate a set of strings into a single large string. + * + * Results: + * The return value is dynamically-allocated string containing + * a concatenation of all the strings in argv, with spaces between + * the original argv elements. + * + * Side effects: + * Memory is allocated for the result; the caller is responsible + * for freeing the memory. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_Concat(argc, argv) + int argc; /* Number of strings to concatenate. */ + char **argv; /* Array of strings to concatenate. */ +{ + int totalSize, i; + register char *p; + char *result; + + for (totalSize = 1, i = 0; i < argc; i++) { + totalSize += strlen(argv[i]) + 1; + } + result = (char *) ckalloc((unsigned) totalSize); + if (argc == 0) { + *result = '\0'; + return result; + } + for (p = result, i = 0; i < argc; i++) { + char *element; + int length; + + /* + * Clip white space off the front and back of the string + * to generate a neater result, and ignore any empty + * elements. + */ + + element = argv[i]; + while (isspace(UCHAR(*element))) { + element++; + } + for (length = strlen(element); + (length > 0) && (isspace(UCHAR(element[length-1]))); + length--) { + /* Null loop body. */ + } + if (length == 0) { + continue; + } + (void) strncpy(p, element, length); + p += length; + *p = ' '; + p++; + } + if (p != result) { + p[-1] = 0; + } else { + *p = 0; + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_StringMatch -- + * + * See if a particular string matches a particular pattern. + * + * Results: + * The return value is 1 if string matches pattern, and + * 0 otherwise. The matching operation permits the following + * special characters in the pattern: *?\[] (see the manual + * entry for details on what these mean). + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_StringMatch(string, pattern) + register char *string; /* String. */ + register char *pattern; /* Pattern, which may contain + * special characters. */ +{ + char c2; + + while (1) { + /* See if we're at the end of both the pattern and the string. + * If so, we succeeded. If we're at the end of the pattern + * but not at the end of the string, we failed. + */ + + if (*pattern == 0) { + if (*string == 0) { + return 1; + } else { + return 0; + } + } + if ((*string == 0) && (*pattern != '*')) { + return 0; + } + + /* Check for a "*" as the next pattern character. It matches + * any substring. We handle this by calling ourselves + * recursively for each postfix of string, until either we + * match or we reach the end of the string. + */ + + if (*pattern == '*') { + pattern += 1; + if (*pattern == 0) { + return 1; + } + while (1) { + if (Tcl_StringMatch(string, pattern)) { + return 1; + } + if (*string == 0) { + return 0; + } + string += 1; + } + } + + /* Check for a "?" as the next pattern character. It matches + * any single character. + */ + + if (*pattern == '?') { + goto thisCharOK; + } + + /* Check for a "[" as the next pattern character. It is followed + * by a list of characters that are acceptable, or by a range + * (two characters separated by "-"). + */ + + if (*pattern == '[') { + pattern += 1; + while (1) { + if ((*pattern == ']') || (*pattern == 0)) { + return 0; + } + if (*pattern == *string) { + break; + } + if (pattern[1] == '-') { + c2 = pattern[2]; + if (c2 == 0) { + return 0; + } + if ((*pattern <= *string) && (c2 >= *string)) { + break; + } + if ((*pattern >= *string) && (c2 <= *string)) { + break; + } + pattern += 2; + } + pattern += 1; + } + while ((*pattern != ']') && (*pattern != 0)) { + pattern += 1; + } + goto thisCharOK; + } + + /* If the next pattern character is '/', just strip off the '/' + * so we do exact matching on the character that follows. + */ + + if (*pattern == '\\') { + pattern += 1; + if (*pattern == 0) { + return 0; + } + } + + /* There's no special character. Just make sure that the next + * characters of each string match. + */ + + if (*pattern != *string) { + return 0; + } + + thisCharOK: pattern += 1; + string += 1; + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetResult -- + * + * Arrange for "string" to be the Tcl return value. + * + * Results: + * None. + * + * Side effects: + * interp->result is left pointing either to "string" (if "copy" is 0) + * or to a copy of string. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_SetResult(interp, string, freeProc) + Tcl_Interp *interp; /* Interpreter with which to associate the + * return value. */ + char *string; /* Value to be returned. If NULL, + * the result is set to an empty string. */ + Tcl_FreeProc *freeProc; /* Gives information about the string: + * TCL_STATIC, TCL_VOLATILE, or the address + * of a Tcl_FreeProc such as free. */ +{ + register Interp *iPtr = (Interp *) interp; + int length; + Tcl_FreeProc *oldFreeProc = iPtr->freeProc; + char *oldResult = iPtr->result; + + iPtr->freeProc = freeProc; + if (string == NULL) { + iPtr->resultSpace[0] = 0; + iPtr->result = iPtr->resultSpace; + iPtr->freeProc = 0; + } else if (freeProc == TCL_VOLATILE) { + length = strlen(string); + if (length > TCL_RESULT_SIZE) { + iPtr->result = (char *) ckalloc((unsigned) length+1); + iPtr->freeProc = (Tcl_FreeProc *) free; + } else { + iPtr->result = iPtr->resultSpace; + iPtr->freeProc = 0; + } + strcpy(iPtr->result, string); + } else { + iPtr->result = string; + } + + /* + * If the old result was dynamically-allocated, free it up. Do it + * here, rather than at the beginning, in case the new result value + * was part of the old result value. + */ + + if (oldFreeProc != 0) { + if (oldFreeProc == (Tcl_FreeProc *) free) { + ckfree(oldResult); + } else { + (*oldFreeProc)(oldResult); + } + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_AppendResult -- + * + * Append a variable number of strings onto the result already + * present for an interpreter. + * + * Results: + * None. + * + * Side effects: + * The result in the interpreter given by the first argument + * is extended by the strings given by the second and following + * arguments (up to a terminating NULL argument). + * + *---------------------------------------------------------------------- + */ + + /* VARARGS2 */ +void +#ifdef USE_STDARG +Tcl_AppendResult(Tcl_Interp *interp, ...) +#else +#ifndef lint +Tcl_AppendResult(va_alist) +#else +void + /* VARARGS2 */ /* ARGSUSED */ +Tcl_AppendResult(interp, p, va_alist) + Tcl_Interp *interp; /* Interpreter whose result is to be + * extended. */ + char *p; /* One or more strings to add to the + * result, terminated with NULL. */ +#endif + va_dcl +#endif +{ + va_list argList; + Interp *iPtr = (Interp *) interp; + char *string; + int newSpace; + + /* + * First, scan through all the arguments to see how much space is + * needed. + */ + +#ifdef USE_STDARG + va_start(argList, interp); +#else + va_start(argList); + (void) va_arg(argList, Interp *); +#endif + newSpace = 0; + while (1) { + string = va_arg(argList, char *); + if (string == NULL) { + break; + } + newSpace += strlen(string); + } + va_end(argList); + + /* + * If the append buffer isn't already setup and large enough + * to hold the new data, set it up. + */ + + if ((iPtr->result != iPtr->appendResult) + || (iPtr->appendResult[iPtr->appendUsed] != 0) + || ((newSpace + iPtr->appendUsed) >= iPtr->appendAvl)) { + SetupAppendBuffer(iPtr, newSpace); + } + + /* + * Final step: go through all the argument strings again, copying + * them into the buffer. + */ + +#ifdef USE_STDARG + va_start(argList, interp); +#else + va_start(argList); + (void) va_arg(argList, Interp *); +#endif + while (1) { + string = va_arg(argList, char *); + if (string == NULL) { + break; + } + strcpy(iPtr->appendResult + iPtr->appendUsed, string); + iPtr->appendUsed += strlen(string); + } + va_end(argList); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_AppendElement -- + * + * Convert a string to a valid Tcl list element and append it + * to the current result (which is ostensibly a list). + * + * Results: + * None. + * + * Side effects: + * The result in the interpreter given by the first argument + * is extended with a list element converted from string. A + * separator space is added before the converted list element + * unless the current result is empty, contains the single + * character "{", or ends in " {". + * + *---------------------------------------------------------------------- + */ + +void +Tcl_AppendElement(interp, string) + Tcl_Interp *interp; /* Interpreter whose result is to be + * extended. */ + char *string; /* String to convert to list element and + * add to result. */ +{ + register Interp *iPtr = (Interp *) interp; + int size, flags; + char *dst; + + /* + * See how much space is needed, and grow the append buffer if + * needed to accommodate the list element. + */ + + size = Tcl_ScanElement(string, &flags) + 1; + if ((iPtr->result != iPtr->appendResult) + || (iPtr->appendResult[iPtr->appendUsed] != 0) + || ((size + iPtr->appendUsed) >= iPtr->appendAvl)) { + SetupAppendBuffer(iPtr, size+iPtr->appendUsed); + } + + /* + * Convert the string into a list element and copy it to the + * buffer that's forming. + */ + + dst = iPtr->appendResult + iPtr->appendUsed; + if ((iPtr->appendUsed > 0) && ((dst[-1] != '{') + || ((iPtr->appendUsed > 1) && (dst[-2] == '\\')))) { + iPtr->appendUsed++; + *dst = ' '; + dst++; + } + iPtr->appendUsed += Tcl_ConvertElement(string, dst, flags); +} + +/* + *---------------------------------------------------------------------- + * + * SetupAppendBuffer -- + * + * This procedure makes sure that there is an append buffer + * properly initialized for interp, and that it has at least + * enough room to accommodate newSpace new bytes of information. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static void +SetupAppendBuffer(iPtr, newSpace) + register Interp *iPtr; /* Interpreter whose result is being set up. */ + int newSpace; /* Make sure that at least this many bytes + * of new information may be added. */ +{ + int totalSpace; + + /* + * Make the append buffer larger, if that's necessary, then + * copy the current result into the append buffer and make the + * append buffer the official Tcl result. + */ + + if (iPtr->result != iPtr->appendResult) { + /* + * If an oversized buffer was used recently, then free it up + * so we go back to a smaller buffer. This avoids tying up + * memory forever after a large operation. + */ + + if (iPtr->appendAvl > 500) { + ckfree(iPtr->appendResult); + iPtr->appendResult = NULL; + iPtr->appendAvl = 0; + } + iPtr->appendUsed = strlen(iPtr->result); + } else if (iPtr->result[iPtr->appendUsed] != 0) { + /* + * Most likely someone has modified a result created by + * Tcl_AppendResult et al. so that it has a different size. + * Just recompute the size. + */ + + iPtr->appendUsed = strlen(iPtr->result); + } + totalSpace = newSpace + iPtr->appendUsed; + if (totalSpace >= iPtr->appendAvl) { + char *new; + + if (totalSpace < 100) { + totalSpace = 200; + } else { + totalSpace *= 2; + } + new = (char *) ckalloc((unsigned) totalSpace); + strcpy(new, iPtr->result); + if (iPtr->appendResult != NULL) { + ckfree(iPtr->appendResult); + } + iPtr->appendResult = new; + iPtr->appendAvl = totalSpace; + } else if (iPtr->result != iPtr->appendResult) { + strcpy(iPtr->appendResult, iPtr->result); + } + Tcl_FreeResult(iPtr); + iPtr->result = iPtr->appendResult; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ResetResult -- + * + * This procedure restores the result area for an interpreter + * to its default initialized state, freeing up any memory that + * may have been allocated for the result and clearing any + * error information for the interpreter. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_ResetResult(interp) + Tcl_Interp *interp; /* Interpreter for which to clear result. */ +{ + register Interp *iPtr = (Interp *) interp; + + Tcl_FreeResult(iPtr); + iPtr->result = iPtr->resultSpace; + iPtr->resultSpace[0] = 0; + iPtr->flags &= + ~(ERR_ALREADY_LOGGED | ERR_IN_PROGRESS | ERROR_CODE_SET); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetErrorCode -- + * + * This procedure is called to record machine-readable information + * about an error that is about to be returned. + * + * Results: + * None. + * + * Side effects: + * The errorCode global variable is modified to hold all of the + * arguments to this procedure, in a list form with each argument + * becoming one element of the list. A flag is set internally + * to remember that errorCode has been set, so the variable doesn't + * get set automatically when the error is returned. + * + *---------------------------------------------------------------------- + */ + /* VARARGS2 */ +void +#ifdef USE_STDARG +Tcl_SetErrorCode(Tcl_Interp *interp, ...) +#else +#ifndef lint +Tcl_SetErrorCode(va_alist) +#else +void + /* VARARGS2 */ /* ARGSUSED */ +Tcl_SetErrorCode(interp, p, va_alist) + Tcl_Interp *interp; /* Interpreter whose errorCode variable is + * to be set. */ + char *p; /* One or more elements to add to errorCode, + * terminated with NULL. */ +#endif + va_dcl +#endif +{ + va_list argList; + char *string; + int flags; + Interp *iPtr = (Interp *)interp; + + /* + * Scan through the arguments one at a time, appending them to + * $errorCode as list elements. + */ + +#ifdef USE_STDARG + va_start(argList, interp); +#else + va_start(argList); +#endif + (void) va_arg(argList, Tcl_Interp *); + flags = TCL_GLOBAL_ONLY | TCL_LIST_ELEMENT; + while (1) { + string = va_arg(argList, char *); + if (string == NULL) { + break; + } + (void) Tcl_SetVar2((Tcl_Interp *) iPtr, "errorCode", + (char *) NULL, string, flags); + flags |= TCL_APPEND_VALUE; + } + va_end(argList); + iPtr->flags |= ERROR_CODE_SET; +} + +/* + *---------------------------------------------------------------------- + * + * TclGetListIndex -- + * + * Parse a list index, which may be either an integer or the + * value "end". + * + * Results: + * The return value is either TCL_OK or TCL_ERROR. If it is + * TCL_OK, then the index corresponding to string is left in + * *indexPtr. If the return value is TCL_ERROR, then string + * was bogus; an error message is returned in interp->result. + * If a negative index is specified, it is rounded up to 0. + * The index value may be larger than the size of the list + * (this happens when "end" is specified). + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclGetListIndex(interp, string, indexPtr) + Tcl_Interp *interp; /* Interpreter for error reporting. */ + char *string; /* String containing list index. */ + int *indexPtr; /* Where to store index. */ +{ + if (isdigit(UCHAR(*string)) || (*string == '-')) { + if (Tcl_GetInt(interp, string, indexPtr) != TCL_OK) { + return TCL_ERROR; + } + if (*indexPtr < 0) { + *indexPtr = 0; + } + } else if (strncmp(string, "end", strlen(string)) == 0) { + *indexPtr = 1<<30; + } else { + Tcl_AppendResult(interp, "bad index \"", string, + "\": must be integer or \"end\"", (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileRegexp -- + * + * Compile a regular expression into a form suitable for fast + * matching. This procedure retains a small cache of pre-compiled + * regular expressions in the interpreter, in order to avoid + * compilation costs as much as possible. + * + * Results: + * The return value is a pointer to the compiled form of string, + * suitable for passing to TclRegExec. If an error occurred while + * compiling the pattern, then NULL is returned and an error + * message is left in interp->result. + * + * Side effects: + * The cache of compiled regexp's in interp will be modified to + * hold information for string, if such information isn't already + * present in the cache. + * + *---------------------------------------------------------------------- + */ + +regexp * +TclCompileRegexp(interp, string) + Tcl_Interp *interp; /* For use in error reporting. */ + char *string; /* String for which to produce + * compiled regular expression. */ +{ + register Interp *iPtr = (Interp *) interp; + int i, length; + regexp *result; + + length = strlen(string); + for (i = 0; i < NUM_REGEXPS; i++) { + if ((length == iPtr->patLengths[i]) + && (strcmp(string, iPtr->patterns[i]) == 0)) { + /* + * Move the matched pattern to the first slot in the + * cache and shift the other patterns down one position. + */ + + if (i != 0) { + int j; + char *cachedString; + + cachedString = iPtr->patterns[i]; + result = iPtr->regexps[i]; + for (j = i-1; j >= 0; j--) { + iPtr->patterns[j+1] = iPtr->patterns[j]; + iPtr->patLengths[j+1] = iPtr->patLengths[j]; + iPtr->regexps[j+1] = iPtr->regexps[j]; + } + iPtr->patterns[0] = cachedString; + iPtr->patLengths[0] = length; + iPtr->regexps[0] = result; + } + return iPtr->regexps[0]; + } + } + + /* + * No match in the cache. Compile the string and add it to the + * cache. + */ + + tclRegexpError = NULL; + result = TclRegComp(string); + if (tclRegexpError != NULL) { + Tcl_AppendResult(interp, + "couldn't compile regular expression pattern: ", + tclRegexpError, (char *) NULL); + return NULL; + } + if (iPtr->patterns[NUM_REGEXPS-1] != NULL) { + ckfree(iPtr->patterns[NUM_REGEXPS-1]); + ckfree((char *) iPtr->regexps[NUM_REGEXPS-1]); + } + for (i = NUM_REGEXPS - 2; i >= 0; i--) { + iPtr->patterns[i+1] = iPtr->patterns[i]; + iPtr->patLengths[i+1] = iPtr->patLengths[i]; + iPtr->regexps[i+1] = iPtr->regexps[i]; + } + iPtr->patterns[0] = (char *) ckalloc((unsigned) (length+1)); + strcpy(iPtr->patterns[0], string); + iPtr->patLengths[0] = length; + iPtr->regexps[0] = result; + return result; +} + +/* + *---------------------------------------------------------------------- + * + * TclRegError -- + * + * This procedure is invoked by the Henry Spencer's regexp code + * when an error occurs. It saves the error message so it can + * be seen by the code that called Spencer's code. + * + * Results: + * None. + * + * Side effects: + * The value of "string" is saved in "tclRegexpError". + * + *---------------------------------------------------------------------- + */ + +void +TclRegError(string) + char *string; /* Error message. */ +{ + tclRegexpError = string; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_RegExpMatch -- + * + * See if a string matches a regular expression. + * + * Results: + * If an error occurs during the matching operation then -1 + * is returned and interp->result contains an error message. + * Otherwise the return value is 1 if "string" matches "pattern" + * and 0 otherwise. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_RegExpMatch(interp, string, pattern) + Tcl_Interp *interp; /* Used for error reporting. */ + char *string; /* String. */ + char *pattern; /* Regular expression to match against + * string. */ +{ + regexp *regexpPtr; + int match; + + regexpPtr = TclCompileRegexp(interp, pattern); + if (regexpPtr == NULL) { + return -1; + } + tclRegexpError = NULL; + match = TclRegExec(regexpPtr, string, string); + if (tclRegexpError != NULL) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "error while matching regular expression: ", + tclRegexpError, (char *) NULL); + return -1; + } + return match; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DStringInit -- + * + * Initializes a dynamic string, discarding any previous contents + * of the string (Tcl_DStringFree should have been called already + * if the dynamic string was previously in use). + * + * Results: + * None. + * + * Side effects: + * The dynamic string is initialized to be empty. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DStringInit(dsPtr) + register Tcl_DString *dsPtr; /* Pointer to structure for + * dynamic string. */ +{ + dsPtr->string = dsPtr->staticSpace; + dsPtr->length = 0; + dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE; + dsPtr->staticSpace[0] = 0; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DStringAppend -- + * + * Append more characters to the current value of a dynamic string. + * + * Results: + * The return value is a pointer to the dynamic string's new value. + * + * Side effects: + * Length bytes from string (or all of string if length is less + * than zero) are added to the current value of the string. Memory + * gets reallocated if needed to accomodate the string's new size. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_DStringAppend(dsPtr, string, length) + register Tcl_DString *dsPtr; /* Structure describing dynamic + * string. */ + char *string; /* String to append. If length is + * -1 then this must be + * null-terminated. */ + int length; /* Number of characters from string + * to append. If < 0, then append all + * of string, up to null at end. */ +{ + int newSize; + char *newString; + + if (length < 0) { + length = strlen(string); + } + newSize = length + dsPtr->length; + + /* + * Allocate a larger buffer for the string if the current one isn't + * large enough. Allocate extra space in the new buffer so that there + * will be room to grow before we have to allocate again. + */ + + if (newSize >= dsPtr->spaceAvl) { + dsPtr->spaceAvl = newSize*2; + newString = (char *) ckalloc((unsigned) dsPtr->spaceAvl); + strcpy(newString, dsPtr->string); + if (dsPtr->string != dsPtr->staticSpace) { + ckfree(dsPtr->string); + } + dsPtr->string = newString; + } + + /* + * Copy the new string into the buffer at the end of the old + * one. + */ + + strncpy(dsPtr->string + dsPtr->length, string, length); + dsPtr->length += length; + dsPtr->string[dsPtr->length] = 0; + return dsPtr->string; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DStringAppendElement -- + * + * Append a list element to the current value of a dynamic string. + * + * Results: + * The return value is a pointer to the dynamic string's new value. + * + * Side effects: + * String is reformatted as a list element and added to the current + * value of the string. Memory gets reallocated if needed to + * accomodate the string's new size. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_DStringAppendElement(dsPtr, string) + register Tcl_DString *dsPtr; /* Structure describing dynamic + * string. */ + char *string; /* String to append. Must be + * null-terminated. */ +{ + int newSize, flags; + char *dst, *newString; + + newSize = Tcl_ScanElement(string, &flags) + dsPtr->length + 1; + + /* + * Allocate a larger buffer for the string if the current one isn't + * large enough. Allocate extra space in the new buffer so that there + * will be room to grow before we have to allocate again. + */ + + if (newSize >= dsPtr->spaceAvl) { + dsPtr->spaceAvl = newSize*2; + newString = (char *) ckalloc((unsigned) dsPtr->spaceAvl); + strcpy(newString, dsPtr->string); + if (dsPtr->string != dsPtr->staticSpace) { + ckfree(dsPtr->string); + } + dsPtr->string = newString; + } + + /* + * Convert the new string to a list element and copy it into the + * buffer at the end. Add a space separator unless we're at the + * start of the string or just after an unbackslashed "{". + */ + + dst = dsPtr->string + dsPtr->length; + if ((dsPtr->length > 0) && ((dst[-1] != '{') + || ((dsPtr->length > 1) && (dst[-2] == '\\')))) { + *dst = ' '; + dst++; + dsPtr->length++; + } + dsPtr->length += Tcl_ConvertElement(string, dst, flags); + return dsPtr->string; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DStringTrunc -- + * + * Truncate a dynamic string to a given length without freeing + * up its storage. + * + * Results: + * None. + * + * Side effects: + * The length of dsPtr is reduced to length unless it was already + * shorter than that. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DStringTrunc(dsPtr, length) + register Tcl_DString *dsPtr; /* Structure describing dynamic + * string. */ + int length; /* New length for dynamic string. */ +{ + if (length < 0) { + length = 0; + } + if (length < dsPtr->length) { + dsPtr->length = length; + dsPtr->string[length] = 0; + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DStringFree -- + * + * Frees up any memory allocated for the dynamic string and + * reinitializes the string to an empty state. + * + * Results: + * None. + * + * Side effects: + * The previous contents of the dynamic string are lost, and + * the new value is an empty string. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DStringFree(dsPtr) + register Tcl_DString *dsPtr; /* Structure describing dynamic + * string. */ +{ + if (dsPtr->string != dsPtr->staticSpace) { + ckfree(dsPtr->string); + } + dsPtr->string = dsPtr->staticSpace; + dsPtr->length = 0; + dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE; + dsPtr->staticSpace[0] = 0; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DStringResult -- + * + * This procedure moves the value of a dynamic string into an + * interpreter as its result. The string itself is reinitialized + * to an empty string. + * + * Results: + * None. + * + * Side effects: + * The string is "moved" to interp's result, and any existing + * result for interp is freed up. DsPtr is reinitialized to + * an empty string. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DStringResult(interp, dsPtr) + Tcl_Interp *interp; /* Interpreter whose result is to be + * reset. */ + Tcl_DString *dsPtr; /* Dynamic string that is to become + * the result of interp. */ +{ + Tcl_FreeResult(interp); + if (dsPtr->string != dsPtr->staticSpace) { + interp->result = dsPtr->string; + interp->freeProc = (Tcl_FreeProc *) free; + } else if (dsPtr->length < TCL_RESULT_SIZE) { + strcpy(interp->result, dsPtr->string); + } else { + Tcl_SetResult(interp, dsPtr->string, TCL_VOLATILE); + } + dsPtr->string = dsPtr->staticSpace; + dsPtr->length = 0; + dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE; + dsPtr->staticSpace[0] = 0; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DStringStartSublist -- + * + * This procedure adds the necessary information to a dynamic + * string (e.g. " {" to start a sublist. Future element + * appends will be in the sublist rather than the main list. + * + * Results: + * None. + * + * Side effects: + * Characters get added to the dynamic string. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DStringStartSublist(dsPtr) + Tcl_DString *dsPtr; /* Dynamic string. */ +{ + if ((dsPtr->length == 0) + || ((dsPtr->length == 1) && (dsPtr->string[0] == '{')) + || ((dsPtr->length > 1) && (dsPtr->string[dsPtr->length-1] == '{') + && (dsPtr->string[dsPtr->length-2] != '\\'))) { + Tcl_DStringAppend(dsPtr, "{", -1); + } else { + Tcl_DStringAppend(dsPtr, " {", -1); + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DStringEndSublist -- + * + * This procedure adds the necessary characters to a dynamic + * string to end a sublist (e.g. "}"). Future element appends + * will be in the enclosing (sub)list rather than the current + * sublist. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DStringEndSublist(dsPtr) + Tcl_DString *dsPtr; /* Dynamic string. */ +{ + Tcl_DStringAppend(dsPtr, "}", -1); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_PrintDouble -- + * + * Given a floating-point value, this procedure converts it to + * an ASCII string using. + * + * Results: + * The ASCII equivalent of "value" is written at "dst". It is + * written using the current precision, and it is guaranteed to + * contain a decimal point or exponent, so that it looks like + * a floating-point value and not an integer. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_PrintDouble(interp, value, dst) + Tcl_Interp *interp; /* Interpreter whose tcl_precision + * variable controls printing. */ + double value; /* Value to print as string. */ + char *dst; /* Where to store converted value; + * must have at least TCL_DOUBLE_SPACE + * characters. */ +{ + register char *p; + sprintf(dst, ((Interp *) interp)->pdFormat, value); + + /* + * If the ASCII result looks like an integer, add ".0" so that it + * doesn't look like an integer anymore. This prevents floating-point + * values from being converted to integers unintentionally. + */ + + for (p = dst; *p != 0; p++) { + if ((*p == '.') || (isalpha(UCHAR(*p)))) { + return; + } + } + p[0] = '.'; + p[1] = '0'; + p[2] = 0; +} + +/* + *---------------------------------------------------------------------- + * + * TclPrecTraceProc -- + * + * This procedure is invoked whenever the variable "tcl_precision" + * is written. + * + * Results: + * Returns NULL if all went well, or an error message if the + * new value for the variable doesn't make sense. + * + * Side effects: + * If the new value doesn't make sense then this procedure + * undoes the effect of the variable modification. Otherwise + * it modifies the format string that's used by Tcl_PrintDouble. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +char * +TclPrecTraceProc(clientData, interp, name1, name2, flags) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Interpreter containing variable. */ + char *name1; /* Name of variable. */ + char *name2; /* Second part of variable name. */ + int flags; /* Information about what happened. */ +{ + register Interp *iPtr = (Interp *) interp; + char *value, *end; + int prec; + + /* + * If the variable is unset, then recreate the trace and restore + * the default value of the format string. + */ + + if (flags & TCL_TRACE_UNSETS) { + if ((flags & TCL_TRACE_DESTROYED) && !(flags & TCL_INTERP_DESTROYED)) { + Tcl_TraceVar2(interp, name1, name2, + TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + TclPrecTraceProc, clientData); + } + strcpy(iPtr->pdFormat, DEFAULT_PD_FORMAT); + iPtr->pdPrec = DEFAULT_PD_PREC; + return (char *) NULL; + } + + value = Tcl_GetVar2(interp, name1, name2, flags & TCL_GLOBAL_ONLY); + if (value == NULL) { + value = ""; + } + prec = strtoul(value, &end, 10); + if ((prec <= 0) || (prec > TCL_MAX_PREC) || (prec > 100) || + (end == value) || (*end != 0)) { + char oldValue[10]; + + sprintf(oldValue, "%d", iPtr->pdPrec); + Tcl_SetVar2(interp, name1, name2, oldValue, flags & TCL_GLOBAL_ONLY); + return "improper value for precision"; + } + sprintf(iPtr->pdFormat, "%%.%dg", prec); + iPtr->pdPrec = prec; + return (char *) NULL; +} diff --git a/vendor/x11iraf/obm/Tcl/tclVar.c b/vendor/x11iraf/obm/Tcl/tclVar.c new file mode 100644 index 00000000..8981cef7 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/tclVar.c @@ -0,0 +1,2363 @@ +/* + * tclVar.c -- + * + * This file contains routines that implement Tcl variables + * (both scalars and arrays). + * + * The implementation of arrays is modelled after an initial + * implementation by Mark Diekhans and Karl Lehenbauer. + * + * Copyright (c) 1987-1993 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. + */ + +#ifndef lint +static char rcsid[] = "$Header: /user6/ouster/tcl/RCS/tclVar.c,v 1.44 93/08/14 17:21:34 ouster Exp $ SPRITE (Berkeley)"; +#endif + +#include "tclInt.h" + +/* + * The strings below are used to indicate what went wrong when a + * variable access is denied. + */ + +static char *noSuchVar = "no such variable"; +static char *isArray = "variable is array"; +static char *needArray = "variable isn't array"; +static char *noSuchElement = "no such element in array"; +static char *danglingUpvar = "upvar refers to element in deleted array"; + +/* + * Creation flag values passed in to LookupVar: + * + * CRT_PART1 - 1 means create hash table entry for part 1 of + * name, if it doesn't already exist. 0 means + * return an error if it doesn't exist. + * CRT_PART2 - 1 means create hash table entry for part 2 of + * name, if it doesn't already exist. 0 means + * return an error if it doesn't exist. + */ + +#define CRT_PART1 1 +#define CRT_PART2 2 + +/* + * Forward references to procedures defined later in this file: + */ + +static char * CallTraces _ANSI_ARGS_((Interp *iPtr, Var *arrayPtr, + Var *varPtr, char *part1, char *part2, + int flags)); +static void CleanupVar _ANSI_ARGS_((Var *varPtr, Var *arrayPtr)); +static void DeleteSearches _ANSI_ARGS_((Var *arrayVarPtr)); +static void DeleteArray _ANSI_ARGS_((Interp *iPtr, char *arrayName, + Var *varPtr, int flags)); +static Var * LookupVar _ANSI_ARGS_((Tcl_Interp *interp, char *part1, + char *part2, int flags, char *msg, int create, + Var **arrayPtrPtr)); +static int MakeUpvar _ANSI_ARGS_((Interp *iPtr, + CallFrame *framePtr, char *otherP1, + char *otherP2, char *myName)); +static Var * NewVar _ANSI_ARGS_((void)); +static ArraySearch * ParseSearchId _ANSI_ARGS_((Tcl_Interp *interp, + Var *varPtr, char *varName, char *string)); +static void VarErrMsg _ANSI_ARGS_((Tcl_Interp *interp, + char *part1, char *part2, char *operation, + char *reason)); + +/* + *---------------------------------------------------------------------- + * + * LookupVar -- + * + * This procedure is used by virtually all of the variable + * code to locate a variable given its name(s). + * + * Results: + * The return value is a pointer to the variable indicated by + * part1 and part2, or NULL if the variable couldn't be found. + * If the variable is found, *arrayPtrPtr is filled in with + * the address of the array that contains the variable (or NULL + * if the variable is a scalar). Note: it's possible that the + * variable returned may be VAR_UNDEFINED, even if CRT_PART1 and + * CRT_PART2 are specified (these only cause the hash table entry + * and/or array to be created). + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static Var * +LookupVar(interp, part1, part2, flags, msg, create, arrayPtrPtr) + Tcl_Interp *interp; /* Interpreter to use for lookup. */ + char *part1; /* If part2 is NULL, this is name of scalar + * variable. Otherwise it is name of array. */ + char *part2; /* Name of an element within array, or NULL. */ + int flags; /* Only the TCL_GLOBAL_ONLY and + * TCL_LEAVE_ERR_MSG bits matter. */ + char *msg; /* Verb to use in error messages, e.g. + * "read" or "set". Only needed if + * TCL_LEAVE_ERR_MSG is set in flags. */ + int create; /* OR'ed combination of CRT_PART1 and + * CRT_PART2. Tells which entries to create + * if they don't already exist. */ + Var **arrayPtrPtr; /* If part2 is non-NULL, *arrayPtrPtr gets + * filled in with address of array variable. */ +{ + Interp *iPtr = (Interp *) interp; + Tcl_HashTable *tablePtr; + Tcl_HashEntry *hPtr; + Var *varPtr; + int new; + + /* + * Lookup part1. + */ + + *arrayPtrPtr = NULL; + if ((flags & TCL_GLOBAL_ONLY) || (iPtr->varFramePtr == NULL)) { + tablePtr = &iPtr->globalTable; + } else { + tablePtr = &iPtr->varFramePtr->varTable; + } + if (create & CRT_PART1) { + hPtr = Tcl_CreateHashEntry(tablePtr, part1, &new); + if (new) { + varPtr = NewVar(); + Tcl_SetHashValue(hPtr, varPtr); + varPtr->hPtr = hPtr; + } + } else { + hPtr = Tcl_FindHashEntry(tablePtr, part1); + if (hPtr == NULL) { + if (flags & TCL_LEAVE_ERR_MSG) { + VarErrMsg(interp, part1, part2, msg, noSuchVar); + } + return NULL; + } + } + varPtr = (Var *) Tcl_GetHashValue(hPtr); + if (varPtr->flags & VAR_UPVAR) { + varPtr = varPtr->value.upvarPtr; + } + + if (part2 == NULL) { + return varPtr; + } + + /* + * We're dealing with an array element, so make sure the variable + * is an array and lookup the element (create it if desired). + */ + + if (varPtr->flags & VAR_UNDEFINED) { + if (!(create & CRT_PART1)) { + if (flags & TCL_LEAVE_ERR_MSG) { + VarErrMsg(interp, part1, part2, msg, noSuchVar); + } + return NULL; + } + varPtr->flags = VAR_ARRAY; + varPtr->value.tablePtr = (Tcl_HashTable *) + ckalloc(sizeof(Tcl_HashTable)); + Tcl_InitHashTable(varPtr->value.tablePtr, TCL_STRING_KEYS); + } else if (!(varPtr->flags & VAR_ARRAY)) { + if (flags & TCL_LEAVE_ERR_MSG) { + VarErrMsg(interp, part1, part2, msg, needArray); + } + return NULL; + } + *arrayPtrPtr = varPtr; + if (create & CRT_PART2) { + hPtr = Tcl_CreateHashEntry(varPtr->value.tablePtr, part2, &new); + if (new) { + if (varPtr->searchPtr != NULL) { + DeleteSearches(varPtr); + } + varPtr = NewVar(); + Tcl_SetHashValue(hPtr, varPtr); + varPtr->hPtr = hPtr; + } + } else { + hPtr = Tcl_FindHashEntry(varPtr->value.tablePtr, part2); + if (hPtr == NULL) { + if (flags & TCL_LEAVE_ERR_MSG) { + VarErrMsg(interp, part1, part2, msg, noSuchElement); + } + return NULL; + } + } + return (Var *) Tcl_GetHashValue(hPtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetVar -- + * + * Return the value of a Tcl variable. + * + * Results: + * The return value points to the current value of varName. If + * the variable is not defined or can't be read because of a clash + * in array usage then a NULL pointer is returned and an error + * message is left in interp->result if the TCL_LEAVE_ERR_MSG + * flag is set. Note: the return value is only valid up until + * the next call to Tcl_SetVar or Tcl_SetVar2; if you depend on + * the value lasting longer than that, then make yourself a private + * copy. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_GetVar(interp, varName, flags) + Tcl_Interp *interp; /* Command interpreter in which varName is + * to be looked up. */ + char *varName; /* Name of a variable in interp. */ + int flags; /* OR-ed combination of TCL_GLOBAL_ONLY + * or TCL_LEAVE_ERR_MSG bits. */ +{ + register char *p; + + /* + * If varName refers to an array (it ends with a parenthesized + * element name), then handle it specially. + */ + + for (p = varName; *p != '\0'; p++) { + if (*p == '(') { + char *result; + char *open = p; + + do { + p++; + } while (*p != '\0'); + p--; + if (*p != ')') { + goto scalar; + } + *open = '\0'; + *p = '\0'; + result = Tcl_GetVar2(interp, varName, open+1, flags); + *open = '('; + *p = ')'; + return result; + } + } + + scalar: + return Tcl_GetVar2(interp, varName, (char *) NULL, flags); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetVar2 -- + * + * Return the value of a Tcl variable, given a two-part name + * consisting of array name and element within array. + * + * Results: + * The return value points to the current value of the variable + * given by part1 and part2. If the specified variable doesn't + * exist, or if there is a clash in array usage, then NULL is + * returned and a message will be left in interp->result if the + * TCL_LEAVE_ERR_MSG flag is set. Note: the return value is + * only valid up until the next call to Tcl_SetVar or Tcl_SetVar2; + * if you depend on the value lasting longer than that, then make + * yourself a private copy. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_GetVar2(interp, part1, part2, flags) + Tcl_Interp *interp; /* Command interpreter in which variable is + * to be looked up. */ + char *part1; /* Name of array (if part2 is NULL) or + * name of variable. */ + char *part2; /* If non-null, gives name of element in + * array. */ + int flags; /* OR-ed combination of TCL_GLOBAL_ONLY + * or TCL_LEAVE_ERR_MSG bits. */ +{ + Var *varPtr, *arrayPtr; + Interp *iPtr = (Interp *) interp; + + varPtr = LookupVar(interp, part1, part2, flags, "read", CRT_PART2, + &arrayPtr); + if (varPtr == NULL) { + return NULL; + } + + /* + * Invoke any traces that have been set for the variable. + */ + + if ((varPtr->tracePtr != NULL) + || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) { + char *msg; + + msg = CallTraces(iPtr, arrayPtr, varPtr, part1, part2, + (flags & TCL_GLOBAL_ONLY) | TCL_TRACE_READS); + if (msg != NULL) { + VarErrMsg(interp, part1, part2, "read", msg); + goto cleanup; + } + } + if (!(varPtr->flags & (VAR_UNDEFINED|VAR_UPVAR|VAR_ARRAY))) { + return varPtr->value.string; + } + if (flags & TCL_LEAVE_ERR_MSG) { + char *msg; + + if ((varPtr->flags & VAR_UNDEFINED) && (arrayPtr != NULL) + && !(arrayPtr->flags & VAR_UNDEFINED)) { + msg = noSuchElement; + } else { + msg = noSuchVar; + } + VarErrMsg(interp, part1, part2, "read", msg); + } + + /* + * If the variable doesn't exist anymore and no-one's using it, + * then free up the relevant structures and hash table entries. + */ + + cleanup: + if (varPtr->flags & VAR_UNDEFINED) { + CleanupVar(varPtr, arrayPtr); + } + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetVar -- + * + * Change the value of a variable. + * + * Results: + * Returns a pointer to the malloc'ed string holding the new + * value of the variable. The caller should not modify this + * string. If the write operation was disallowed then NULL + * is returned; if the TCL_LEAVE_ERR_MSG flag is set, then + * an explanatory message will be left in interp->result. + * + * Side effects: + * If varName is defined as a local or global variable in interp, + * its value is changed to newValue. If varName isn't currently + * defined, then a new global variable by that name is created. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_SetVar(interp, varName, newValue, flags) + Tcl_Interp *interp; /* Command interpreter in which varName is + * to be looked up. */ + char *varName; /* Name of a variable in interp. */ + char *newValue; /* New value for varName. */ + int flags; /* Various flags that tell how to set value: + * any of TCL_GLOBAL_ONLY, TCL_APPEND_VALUE, + * TCL_LIST_ELEMENT, or TCL_LEAVE_ERR_MSG. */ +{ + register char *p; + + /* + * If varName refers to an array (it ends with a parenthesized + * element name), then handle it specially. + */ + + for (p = varName; *p != '\0'; p++) { + if (*p == '(') { + char *result; + char *open = p; + + do { + p++; + } while (*p != '\0'); + p--; + if (*p != ')') { + goto scalar; + } + *open = '\0'; + *p = '\0'; + result = Tcl_SetVar2(interp, varName, open+1, newValue, flags); + *open = '('; + *p = ')'; + return result; + } + } + + scalar: + return Tcl_SetVar2(interp, varName, (char *) NULL, newValue, flags); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetVar2 -- + * + * Given a two-part variable name, which may refer either to a + * scalar variable or an element of an array, change the value + * of the variable. If the named scalar or array or element + * doesn't exist then create one. + * + * Results: + * Returns a pointer to the malloc'ed string holding the new + * value of the variable. The caller should not modify this + * string. If the write operation was disallowed because an + * array was expected but not found (or vice versa), then NULL + * is returned; if the TCL_LEAVE_ERR_MSG flag is set, then + * an explanatory message will be left in interp->result. + * + * Side effects: + * The value of the given variable is set. If either the array + * or the entry didn't exist then a new one is created. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_SetVar2(interp, part1, part2, newValue, flags) + Tcl_Interp *interp; /* Command interpreter in which variable is + * to be looked up. */ + char *part1; /* If part2 is NULL, this is name of scalar + * variable. Otherwise it is name of array. */ + char *part2; /* Name of an element within array, or NULL. */ + char *newValue; /* New value for variable. */ + int flags; /* Various flags that tell how to set value: + * any of TCL_GLOBAL_ONLY, TCL_APPEND_VALUE, + * TCL_LIST_ELEMENT, or TCL_LEAVE_ERR_MSG . */ +{ + register Var *varPtr; + register Interp *iPtr = (Interp *) interp; + int length, listFlags; + Var *arrayPtr; + char *result; + + varPtr = LookupVar(interp, part1, part2, flags, "set", CRT_PART1|CRT_PART2, + &arrayPtr); + if (varPtr == NULL) { + return NULL; + } + + /* + * If the variable's hPtr field is NULL, it means that this is an + * upvar to an array element where the array was deleted, leaving + * the element dangling at the end of the upvar. Generate an error + * (allowing the variable to be reset would screw up our storage + * allocation and is meaningless anyway). + */ + + if (varPtr->hPtr == NULL) { + if (flags & TCL_LEAVE_ERR_MSG) { + VarErrMsg(interp, part1, part2, "set", danglingUpvar); + } + return NULL; + } + + /* + * Clear the variable's current value unless this is an + * append operation. + */ + + if (varPtr->flags & VAR_ARRAY) { + if (flags & TCL_LEAVE_ERR_MSG) { + VarErrMsg(interp, part1, part2, "set", isArray); + } + return NULL; + } + if (!(flags & TCL_APPEND_VALUE) || (varPtr->flags & VAR_UNDEFINED)) { + varPtr->valueLength = 0; + } + + /* + * Compute how many total bytes will be needed for the variable's + * new value (leave space for a separating space between list + * elements). Allocate new space for the value if needed. + */ + + if (flags & TCL_LIST_ELEMENT) { + length = Tcl_ScanElement(newValue, &listFlags) + 1; + } else { + length = strlen(newValue); + } + length += varPtr->valueLength; + if (length >= varPtr->valueSpace) { + char *newValue; + int newSize; + + newSize = 2*varPtr->valueSpace; + if (newSize <= length) { + newSize = length + 1; + } + if (newSize < 24) { + /* + * Don't waste time with teensy-tiny variables; we'll + * just end up expanding them later. + */ + + newSize = 24; + } + newValue = ckalloc((unsigned) newSize); + if (varPtr->valueSpace > 0) { + strcpy(newValue, varPtr->value.string); + ckfree(varPtr->value.string); + } + varPtr->valueSpace = newSize; + varPtr->value.string = newValue; + } + + /* + * Append the new value to the variable, either as a list + * element or as a string. + */ + + if (flags & TCL_LIST_ELEMENT) { + char *dst = varPtr->value.string + varPtr->valueLength; + + if ((varPtr->valueLength > 0) && ((dst[-1] != '{') + || ((varPtr->valueLength > 1) && (dst[-2] == '\\')))) { + *dst = ' '; + dst++; + varPtr->valueLength++; + } + varPtr->valueLength += Tcl_ConvertElement(newValue, dst, listFlags); + } else { + strcpy(varPtr->value.string + varPtr->valueLength, newValue); + varPtr->valueLength = length; + } + varPtr->flags &= ~VAR_UNDEFINED; + + /* + * Invoke any write traces for the variable. + */ + + if ((varPtr->tracePtr != NULL) + || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) { + char *msg; + + msg = CallTraces(iPtr, arrayPtr, varPtr, part1, part2, + (flags & TCL_GLOBAL_ONLY) | TCL_TRACE_WRITES); + if (msg != NULL) { + VarErrMsg(interp, part1, part2, "set", msg); + result = NULL; + goto cleanup; + } + } + + /* + * If the variable was changed in some gross way by a trace (e.g. + * it was unset and then recreated as an array) then just return + * an empty string; otherwise return the variable's current + * value. + */ + + if (!(varPtr->flags & (VAR_UNDEFINED|VAR_UPVAR|VAR_ARRAY))) { + return varPtr->value.string; + } + result = ""; + + /* + * If the variable doesn't exist anymore and no-one's using it, + * then free up the relevant structures and hash table entries. + */ + + cleanup: + if (varPtr->flags & VAR_UNDEFINED) { + CleanupVar(varPtr, arrayPtr); + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_UnsetVar -- + * + * Delete a variable, so that it may not be accessed anymore. + * + * Results: + * Returns TCL_OK if the variable was successfully deleted, TCL_ERROR + * if the variable can't be unset. In the event of an error, + * if the TCL_LEAVE_ERR_MSG flag is set then an error message + * is left in interp->result. + * + * Side effects: + * If varName is defined as a local or global variable in interp, + * it is deleted. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_UnsetVar(interp, varName, flags) + Tcl_Interp *interp; /* Command interpreter in which varName is + * to be looked up. */ + char *varName; /* Name of a variable in interp. May be + * either a scalar name or an array name + * or an element in an array. */ + int flags; /* OR-ed combination of any of + * TCL_GLOBAL_ONLY or TCL_LEAVE_ERR_MSG. */ +{ + register char *p; + int result; + + /* + * Figure out whether this is an array reference, then call + * Tcl_UnsetVar2 to do all the real work. + */ + + for (p = varName; *p != '\0'; p++) { + if (*p == '(') { + char *open = p; + + do { + p++; + } while (*p != '\0'); + p--; + if (*p != ')') { + goto scalar; + } + *open = '\0'; + *p = '\0'; + result = Tcl_UnsetVar2(interp, varName, open+1, flags); + *open = '('; + *p = ')'; + return result; + } + } + + scalar: + return Tcl_UnsetVar2(interp, varName, (char *) NULL, flags); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_UnsetVar2 -- + * + * Delete a variable, given a 2-part name. + * + * Results: + * Returns TCL_OK if the variable was successfully deleted, TCL_ERROR + * if the variable can't be unset. In the event of an error, + * if the TCL_LEAVE_ERR_MSG flag is set then an error message + * is left in interp->result. + * + * Side effects: + * If part1 and part2 indicate a local or global variable in interp, + * it is deleted. If part1 is an array name and part2 is NULL, then + * the whole array is deleted. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_UnsetVar2(interp, part1, part2, flags) + Tcl_Interp *interp; /* Command interpreter in which varName is + * to be looked up. */ + char *part1; /* Name of variable or array. */ + char *part2; /* Name of element within array or NULL. */ + int flags; /* OR-ed combination of any of + * TCL_GLOBAL_ONLY or TCL_LEAVE_ERR_MSG. */ +{ + Var *varPtr, dummyVar; + Interp *iPtr = (Interp *) interp; + Var *arrayPtr; + ActiveVarTrace *activePtr; + int result; + + varPtr = LookupVar(interp, part1, part2, flags, "unset", 0, &arrayPtr); + if (varPtr == NULL) { + return TCL_ERROR; + } + result = (varPtr->flags & VAR_UNDEFINED) ? TCL_ERROR : TCL_OK; + + if ((part2 != NULL) && (arrayPtr->searchPtr != NULL)) { + DeleteSearches(arrayPtr); + } + + /* + * The code below is tricky, because of the possibility that + * a trace procedure might try to access a variable being + * deleted. To handle this situation gracefully, do things + * in three steps: + * 1. Copy the contents of the variable to a dummy variable + * structure, and mark the original structure as undefined. + * 2. Invoke traces and clean up the variable, using the copy. + * 3. If at the end of this the original variable is still + * undefined and has no outstanding references, then delete + * it (but it could have gotten recreated by a trace). + */ + + dummyVar = *varPtr; + varPtr->valueSpace = 0; + varPtr->flags = VAR_UNDEFINED; + varPtr->tracePtr = NULL; + + /* + * Call trace procedures for the variable being deleted and delete + * its traces. Be sure to abort any other traces for the variable + * that are still pending. Special tricks: + * 1. Increment varPtr's refCount around this: CallTraces will + * use dummyVar so it won't increment varPtr's refCount. + * 2. Turn off the VAR_TRACE_ACTIVE flag in dummyVar: we want to + * call unset traces even if other traces are pending. + */ + + if ((dummyVar.tracePtr != NULL) + || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) { + varPtr->refCount++; + dummyVar.flags &= ~VAR_TRACE_ACTIVE; + (void) CallTraces(iPtr, arrayPtr, &dummyVar, part1, part2, + (flags & TCL_GLOBAL_ONLY) | TCL_TRACE_UNSETS); + while (dummyVar.tracePtr != NULL) { + VarTrace *tracePtr = dummyVar.tracePtr; + dummyVar.tracePtr = tracePtr->nextPtr; + ckfree((char *) tracePtr); + } + for (activePtr = iPtr->activeTracePtr; activePtr != NULL; + activePtr = activePtr->nextPtr) { + if (activePtr->varPtr == varPtr) { + activePtr->nextTracePtr = NULL; + } + } + varPtr->refCount--; + } + + /* + * If the variable is an array, delete all of its elements. This + * must be done after calling the traces on the array, above (that's + * the way traces are defined). + */ + + if (dummyVar.flags & VAR_ARRAY) { + DeleteArray(iPtr, part1, &dummyVar, + (flags & TCL_GLOBAL_ONLY) | TCL_TRACE_UNSETS); + } + if (dummyVar.valueSpace > 0) { + ckfree(dummyVar.value.string); + } + if (result == TCL_ERROR) { + if (flags & TCL_LEAVE_ERR_MSG) { + VarErrMsg(interp, part1, part2, "unset", + (part2 == NULL) ? noSuchVar : noSuchElement); + } + } + + /* + * Finally, if the variable is truly not in use then free up its + * record and remove it from the hash table. + */ + + CleanupVar(varPtr, arrayPtr); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_TraceVar -- + * + * Arrange for reads and/or writes to a variable to cause a + * procedure to be invoked, which can monitor the operations + * and/or change their actions. + * + * Results: + * A standard Tcl return value. + * + * Side effects: + * A trace is set up on the variable given by varName, such that + * future references to the variable will be intermediated by + * proc. See the manual entry for complete details on the calling + * sequence for proc. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_TraceVar(interp, varName, flags, proc, clientData) + Tcl_Interp *interp; /* Interpreter in which variable is + * to be traced. */ + char *varName; /* Name of variable; may end with "(index)" + * to signify an array reference. */ + int flags; /* OR-ed collection of bits, including any + * of TCL_TRACE_READS, TCL_TRACE_WRITES, + * TCL_TRACE_UNSETS, and TCL_GLOBAL_ONLY. */ + Tcl_VarTraceProc *proc; /* Procedure to call when specified ops are + * invoked upon varName. */ + ClientData clientData; /* Arbitrary argument to pass to proc. */ +{ + register char *p; + + /* + * If varName refers to an array (it ends with a parenthesized + * element name), then handle it specially. + */ + + for (p = varName; *p != '\0'; p++) { + if (*p == '(') { + int result; + char *open = p; + + do { + p++; + } while (*p != '\0'); + p--; + if (*p != ')') { + goto scalar; + } + *open = '\0'; + *p = '\0'; + result = Tcl_TraceVar2(interp, varName, open+1, flags, + proc, clientData); + *open = '('; + *p = ')'; + return result; + } + } + + scalar: + return Tcl_TraceVar2(interp, varName, (char *) NULL, flags, + proc, clientData); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_TraceVar2 -- + * + * Arrange for reads and/or writes to a variable to cause a + * procedure to be invoked, which can monitor the operations + * and/or change their actions. + * + * Results: + * A standard Tcl return value. + * + * Side effects: + * A trace is set up on the variable given by part1 and part2, such + * that future references to the variable will be intermediated by + * proc. See the manual entry for complete details on the calling + * sequence for proc. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_TraceVar2(interp, part1, part2, flags, proc, clientData) + Tcl_Interp *interp; /* Interpreter in which variable is + * to be traced. */ + char *part1; /* Name of scalar variable or array. */ + char *part2; /* Name of element within array; NULL means + * trace applies to scalar variable or array + * as-a-whole. */ + int flags; /* OR-ed collection of bits, including any + * of TCL_TRACE_READS, TCL_TRACE_WRITES, + * TCL_TRACE_UNSETS, and TCL_GLOBAL_ONLY. */ + Tcl_VarTraceProc *proc; /* Procedure to call when specified ops are + * invoked upon varName. */ + ClientData clientData; /* Arbitrary argument to pass to proc. */ +{ + Var *varPtr, *arrayPtr; + register VarTrace *tracePtr; + + varPtr = LookupVar(interp, part1, part2, (flags | TCL_LEAVE_ERR_MSG), + "trace", CRT_PART1|CRT_PART2, &arrayPtr); + if (varPtr == NULL) { + return TCL_ERROR; + } + + /* + * Set up trace information. + */ + + tracePtr = (VarTrace *) ckalloc(sizeof(VarTrace)); + tracePtr->traceProc = proc; + tracePtr->clientData = clientData; + tracePtr->flags = flags & + (TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS); + tracePtr->nextPtr = varPtr->tracePtr; + varPtr->tracePtr = tracePtr; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_UntraceVar -- + * + * Remove a previously-created trace for a variable. + * + * Results: + * None. + * + * Side effects: + * If there exists a trace for the variable given by varName + * with the given flags, proc, and clientData, then that trace + * is removed. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_UntraceVar(interp, varName, flags, proc, clientData) + Tcl_Interp *interp; /* Interpreter containing traced variable. */ + char *varName; /* Name of variable; may end with "(index)" + * to signify an array reference. */ + int flags; /* OR-ed collection of bits describing + * current trace, including any of + * TCL_TRACE_READS, TCL_TRACE_WRITES, + * TCL_TRACE_UNSETS, and TCL_GLOBAL_ONLY. */ + Tcl_VarTraceProc *proc; /* Procedure assocated with trace. */ + ClientData clientData; /* Arbitrary argument to pass to proc. */ +{ + register char *p; + + /* + * If varName refers to an array (it ends with a parenthesized + * element name), then handle it specially. + */ + + for (p = varName; *p != '\0'; p++) { + if (*p == '(') { + char *open = p; + + do { + p++; + } while (*p != '\0'); + p--; + if (*p != ')') { + goto scalar; + } + *open = '\0'; + *p = '\0'; + Tcl_UntraceVar2(interp, varName, open+1, flags, proc, clientData); + *open = '('; + *p = ')'; + return; + } + } + + scalar: + Tcl_UntraceVar2(interp, varName, (char *) NULL, flags, proc, clientData); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_UntraceVar2 -- + * + * Remove a previously-created trace for a variable. + * + * Results: + * None. + * + * Side effects: + * If there exists a trace for the variable given by part1 + * and part2 with the given flags, proc, and clientData, then + * that trace is removed. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_UntraceVar2(interp, part1, part2, flags, proc, clientData) + Tcl_Interp *interp; /* Interpreter containing traced variable. */ + char *part1; /* Name of variable or array. */ + char *part2; /* Name of element within array; NULL means + * trace applies to scalar variable or array + * as-a-whole. */ + int flags; /* OR-ed collection of bits describing + * current trace, including any of + * TCL_TRACE_READS, TCL_TRACE_WRITES, + * TCL_TRACE_UNSETS, and TCL_GLOBAL_ONLY. */ + Tcl_VarTraceProc *proc; /* Procedure assocated with trace. */ + ClientData clientData; /* Arbitrary argument to pass to proc. */ +{ + register VarTrace *tracePtr; + VarTrace *prevPtr; + Var *varPtr, *arrayPtr; + Interp *iPtr = (Interp *) interp; + ActiveVarTrace *activePtr; + + varPtr = LookupVar(interp, part1, part2, flags & TCL_GLOBAL_ONLY, + (char *) NULL, 0, &arrayPtr); + if (varPtr == NULL) { + return; + } + + flags &= (TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS); + for (tracePtr = varPtr->tracePtr, prevPtr = NULL; ; + prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) { + if (tracePtr == NULL) { + return; + } + if ((tracePtr->traceProc == proc) && (tracePtr->flags == flags) + && (tracePtr->clientData == clientData)) { + break; + } + } + + /* + * The code below makes it possible to delete traces while traces + * are active: it makes sure that the deleted trace won't be + * processed by CallTraces. + */ + + for (activePtr = iPtr->activeTracePtr; activePtr != NULL; + activePtr = activePtr->nextPtr) { + if (activePtr->nextTracePtr == tracePtr) { + activePtr->nextTracePtr = tracePtr->nextPtr; + } + } + if (prevPtr == NULL) { + varPtr->tracePtr = tracePtr->nextPtr; + } else { + prevPtr->nextPtr = tracePtr->nextPtr; + } + ckfree((char *) tracePtr); + + /* + * If this is the last trace on the variable, and the variable is + * unset and unused, then free up the variable. + */ + + if (varPtr->flags & VAR_UNDEFINED) { + CleanupVar(varPtr, (Var *) NULL); + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_VarTraceInfo -- + * + * Return the clientData value associated with a trace on a + * variable. This procedure can also be used to step through + * all of the traces on a particular variable that have the + * same trace procedure. + * + * Results: + * The return value is the clientData value associated with + * a trace on the given variable. Information will only be + * returned for a trace with proc as trace procedure. If + * the clientData argument is NULL then the first such trace is + * returned; otherwise, the next relevant one after the one + * given by clientData will be returned. If the variable + * doesn't exist, or if there are no (more) traces for it, + * then NULL is returned. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +ClientData +Tcl_VarTraceInfo(interp, varName, flags, proc, prevClientData) + Tcl_Interp *interp; /* Interpreter containing variable. */ + char *varName; /* Name of variable; may end with "(index)" + * to signify an array reference. */ + int flags; /* 0 or TCL_GLOBAL_ONLY. */ + Tcl_VarTraceProc *proc; /* Procedure assocated with trace. */ + ClientData prevClientData; /* If non-NULL, gives last value returned + * by this procedure, so this call will + * return the next trace after that one. + * If NULL, this call will return the + * first trace. */ +{ + register char *p; + + /* + * If varName refers to an array (it ends with a parenthesized + * element name), then handle it specially. + */ + + for (p = varName; *p != '\0'; p++) { + if (*p == '(') { + ClientData result; + char *open = p; + + do { + p++; + } while (*p != '\0'); + p--; + if (*p != ')') { + goto scalar; + } + *open = '\0'; + *p = '\0'; + result = Tcl_VarTraceInfo2(interp, varName, open+1, flags, proc, + prevClientData); + *open = '('; + *p = ')'; + return result; + } + } + + scalar: + return Tcl_VarTraceInfo2(interp, varName, (char *) NULL, flags, proc, + prevClientData); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_VarTraceInfo2 -- + * + * Same as Tcl_VarTraceInfo, except takes name in two pieces + * instead of one. + * + * Results: + * Same as Tcl_VarTraceInfo. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +ClientData +Tcl_VarTraceInfo2(interp, part1, part2, flags, proc, prevClientData) + Tcl_Interp *interp; /* Interpreter containing variable. */ + char *part1; /* Name of variable or array. */ + char *part2; /* Name of element within array; NULL means + * trace applies to scalar variable or array + * as-a-whole. */ + int flags; /* 0 or TCL_GLOBAL_ONLY. */ + Tcl_VarTraceProc *proc; /* Procedure assocated with trace. */ + ClientData prevClientData; /* If non-NULL, gives last value returned + * by this procedure, so this call will + * return the next trace after that one. + * If NULL, this call will return the + * first trace. */ +{ + register VarTrace *tracePtr; + Var *varPtr, *arrayPtr; + + varPtr = LookupVar(interp, part1, part2, flags & TCL_GLOBAL_ONLY, + (char *) NULL, 0, &arrayPtr); + if (varPtr == NULL) { + return NULL; + } + + /* + * Find the relevant trace, if any, and return its clientData. + */ + + tracePtr = varPtr->tracePtr; + if (prevClientData != NULL) { + for ( ; tracePtr != NULL; tracePtr = tracePtr->nextPtr) { + if ((tracePtr->clientData == prevClientData) + && (tracePtr->traceProc == proc)) { + tracePtr = tracePtr->nextPtr; + break; + } + } + } + for ( ; tracePtr != NULL; tracePtr = tracePtr->nextPtr) { + if (tracePtr->traceProc == proc) { + return tracePtr->clientData; + } + } + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetCmd -- + * + * This procedure is invoked to process the "set" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result value. + * + * Side effects: + * A variable's value may be changed. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_SetCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + register Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + if (argc == 2) { + char *value; + + value = Tcl_GetVar(interp, argv[1], TCL_LEAVE_ERR_MSG); + if (value == NULL) { + return TCL_ERROR; + } + interp->result = value; + return TCL_OK; + } else if (argc == 3) { + char *result; + + result = Tcl_SetVar(interp, argv[1], argv[2], TCL_LEAVE_ERR_MSG); + if (result == NULL) { + return TCL_ERROR; + } + interp->result = result; + return TCL_OK; + } else { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " varName ?newValue?\"", (char *) NULL); + return TCL_ERROR; + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_UnsetCmd -- + * + * This procedure is invoked to process the "unset" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result value. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_UnsetCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + register Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int i; + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " varName ?varName ...?\"", (char *) NULL); + return TCL_ERROR; + } + for (i = 1; i < argc; i++) { + if (Tcl_UnsetVar(interp, argv[i], TCL_LEAVE_ERR_MSG) != TCL_OK) { + return TCL_ERROR; + } + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_AppendCmd -- + * + * This procedure is invoked to process the "append" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result value. + * + * Side effects: + * A variable's value may be changed. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_AppendCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + register Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int i; + char *result = NULL; /* (Initialization only needed to keep + * the compiler from complaining) */ + + if (argc < 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " varName value ?value ...?\"", (char *) NULL); + return TCL_ERROR; + } + + for (i = 2; i < argc; i++) { + result = Tcl_SetVar(interp, argv[1], argv[i], + TCL_APPEND_VALUE|TCL_LEAVE_ERR_MSG); + if (result == NULL) { + return TCL_ERROR; + } + } + interp->result = result; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_LappendCmd -- + * + * This procedure is invoked to process the "lappend" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result value. + * + * Side effects: + * A variable's value may be changed. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_LappendCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + register Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int i; + char *result = NULL; /* (Initialization only needed to keep + * the compiler from complaining) */ + + if (argc < 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " varName value ?value ...?\"", (char *) NULL); + return TCL_ERROR; + } + + for (i = 2; i < argc; i++) { + result = Tcl_SetVar(interp, argv[1], argv[i], + TCL_APPEND_VALUE|TCL_LIST_ELEMENT|TCL_LEAVE_ERR_MSG); + if (result == NULL) { + return TCL_ERROR; + } + } + interp->result = result; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ArrayCmd -- + * + * This procedure is invoked to process the "array" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result value. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_ArrayCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + register Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int length; + char c; + Var *varPtr; + Tcl_HashEntry *hPtr; + Interp *iPtr = (Interp *) interp; + + if (argc < 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " option arrayName ?arg ...?\"", (char *) NULL); + return TCL_ERROR; + } + + /* + * Locate the array variable (and it better be an array). + */ + + if (iPtr->varFramePtr == NULL) { + hPtr = Tcl_FindHashEntry(&iPtr->globalTable, argv[2]); + } else { + hPtr = Tcl_FindHashEntry(&iPtr->varFramePtr->varTable, argv[2]); + } + if (hPtr == NULL) { + notArray: + Tcl_AppendResult(interp, "\"", argv[2], "\" isn't an array", + (char *) NULL); + return TCL_ERROR; + } + varPtr = (Var *) Tcl_GetHashValue(hPtr); + if (varPtr->flags & VAR_UPVAR) { + varPtr = varPtr->value.upvarPtr; + } + if (!(varPtr->flags & VAR_ARRAY)) { + goto notArray; + } + + /* + * Dispatch based on the option. + */ + + c = argv[1][0]; + length = strlen(argv[1]); + if ((c == 'a') && (strncmp(argv[1], "anymore", length) == 0)) { + ArraySearch *searchPtr; + + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " anymore arrayName searchId\"", (char *) NULL); + return TCL_ERROR; + } + searchPtr = ParseSearchId(interp, varPtr, argv[2], argv[3]); + if (searchPtr == NULL) { + return TCL_ERROR; + } + while (1) { + Var *varPtr2; + + if (searchPtr->nextEntry != NULL) { + varPtr2 = (Var *) Tcl_GetHashValue(searchPtr->nextEntry); + if (!(varPtr2->flags & VAR_UNDEFINED)) { + break; + } + } + searchPtr->nextEntry = Tcl_NextHashEntry(&searchPtr->search); + if (searchPtr->nextEntry == NULL) { + interp->result = "0"; + return TCL_OK; + } + } + interp->result = "1"; + return TCL_OK; + } else if ((c == 'd') && (strncmp(argv[1], "donesearch", length) == 0)) { + ArraySearch *searchPtr, *prevPtr; + + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " donesearch arrayName searchId\"", (char *) NULL); + return TCL_ERROR; + } + searchPtr = ParseSearchId(interp, varPtr, argv[2], argv[3]); + if (searchPtr == NULL) { + return TCL_ERROR; + } + if (varPtr->searchPtr == searchPtr) { + varPtr->searchPtr = searchPtr->nextPtr; + } else { + for (prevPtr = varPtr->searchPtr; ; prevPtr = prevPtr->nextPtr) { + if (prevPtr->nextPtr == searchPtr) { + prevPtr->nextPtr = searchPtr->nextPtr; + break; + } + } + } + ckfree((char *) searchPtr); + } else if ((c == 'n') && (strncmp(argv[1], "names", length) == 0) + && (length >= 2)) { + Tcl_HashSearch search; + Var *varPtr2; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " names arrayName\"", (char *) NULL); + return TCL_ERROR; + } + for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search); + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + varPtr2 = (Var *) Tcl_GetHashValue(hPtr); + if (varPtr2->flags & VAR_UNDEFINED) { + continue; + } + Tcl_AppendElement(interp, + Tcl_GetHashKey(varPtr->value.tablePtr, hPtr)); + } + } else if ((c == 'n') && (strncmp(argv[1], "nextelement", length) == 0) + && (length >= 2)) { + ArraySearch *searchPtr; + Tcl_HashEntry *hPtr; + + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " nextelement arrayName searchId\"", + (char *) NULL); + return TCL_ERROR; + } + searchPtr = ParseSearchId(interp, varPtr, argv[2], argv[3]); + if (searchPtr == NULL) { + return TCL_ERROR; + } + while (1) { + Var *varPtr2; + + hPtr = searchPtr->nextEntry; + if (hPtr == NULL) { + hPtr = Tcl_NextHashEntry(&searchPtr->search); + if (hPtr == NULL) { + return TCL_OK; + } + } else { + searchPtr->nextEntry = NULL; + } + varPtr2 = (Var *) Tcl_GetHashValue(hPtr); + if (!(varPtr2->flags & VAR_UNDEFINED)) { + break; + } + } + interp->result = Tcl_GetHashKey(varPtr->value.tablePtr, hPtr); + } else if ((c == 's') && (strncmp(argv[1], "size", length) == 0) + && (length >= 2)) { + Tcl_HashSearch search; + Var *varPtr2; + int size; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " size arrayName\"", (char *) NULL); + return TCL_ERROR; + } + size = 0; + for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search); + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + varPtr2 = (Var *) Tcl_GetHashValue(hPtr); + if (varPtr2->flags & VAR_UNDEFINED) { + continue; + } + size++; + } + sprintf(interp->result, "%d", size); + } else if ((c == 's') && (strncmp(argv[1], "startsearch", length) == 0) + && (length >= 2)) { + ArraySearch *searchPtr; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " startsearch arrayName\"", (char *) NULL); + return TCL_ERROR; + } + searchPtr = (ArraySearch *) ckalloc(sizeof(ArraySearch)); + if (varPtr->searchPtr == NULL) { + searchPtr->id = 1; + Tcl_AppendResult(interp, "s-1-", argv[2], (char *) NULL); + } else { + char string[20]; + + searchPtr->id = varPtr->searchPtr->id + 1; + sprintf(string, "%d", searchPtr->id); + Tcl_AppendResult(interp, "s-", string, "-", argv[2], + (char *) NULL); + } + searchPtr->varPtr = varPtr; + searchPtr->nextEntry = Tcl_FirstHashEntry(varPtr->value.tablePtr, + &searchPtr->search); + searchPtr->nextPtr = varPtr->searchPtr; + varPtr->searchPtr = searchPtr; + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": should be anymore, donesearch, names, nextelement, ", + "size, or startsearch", (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * MakeUpvar -- + * + * This procedure does all of the work of the "global" and "upvar" + * commands. + * + * Results: + * A standard Tcl completion code. If an error occurs then an + * error message is left in iPtr->result. + * + * Side effects: + * The variable given by myName is linked to the variable in + * framePtr given by otherP1 and otherP2, so that references to + * myName are redirected to the other variable like a symbolic +* link. + * + *---------------------------------------------------------------------- + */ + +static int +MakeUpvar(iPtr, framePtr, otherP1, otherP2, myName) + Interp *iPtr; /* Interpreter containing variables. Used + * for error messages, too. */ + CallFrame *framePtr; /* Call frame containing "other" variable. + * NULL means use global context. */ + char *otherP1, *otherP2; /* Two-part name of variable in framePtr. */ + char *myName; /* Name of variable in local table, which + * will refer to otherP1/P2. Must be a + * scalar. */ +{ + Tcl_HashEntry *hPtr; + Var *otherPtr, *varPtr, *arrayPtr; + CallFrame *savedFramePtr; + int new; + + /* + * In order to use LookupVar to find "other", temporarily replace + * the current frame pointer in the interpreter. + */ + + savedFramePtr = iPtr->varFramePtr; + iPtr->varFramePtr = framePtr; + otherPtr = LookupVar((Tcl_Interp *) iPtr, otherP1, otherP2, + TCL_LEAVE_ERR_MSG, "access", CRT_PART1|CRT_PART2, &arrayPtr); + iPtr->varFramePtr = savedFramePtr; + if (otherPtr == NULL) { + return TCL_ERROR; + } + if (iPtr->varFramePtr != NULL) { + hPtr = Tcl_CreateHashEntry(&iPtr->varFramePtr->varTable, myName, &new); + } else { + hPtr = Tcl_CreateHashEntry(&iPtr->globalTable, myName, &new); + } + if (new) { + varPtr = NewVar(); + Tcl_SetHashValue(hPtr, varPtr); + varPtr->hPtr = hPtr; + } else { + /* + * The variable already exists. If it's not an upvar then it's + * an error. If it is an upvar, then just disconnect it from the + * thing it currently refers to. + */ + + varPtr = (Var *) Tcl_GetHashValue(hPtr); + if (varPtr->flags & VAR_UPVAR) { + Var *upvarPtr; + + upvarPtr = varPtr->value.upvarPtr; + if (upvarPtr == otherPtr) { + return TCL_OK; + } + upvarPtr->refCount--; + if (upvarPtr->flags & VAR_UNDEFINED) { + CleanupVar(upvarPtr, (Var *) NULL); + } + } else if (!(varPtr->flags & VAR_UNDEFINED)) { + Tcl_AppendResult((Tcl_Interp *) iPtr, "variable \"", myName, + "\" already exists", (char *) NULL); + return TCL_ERROR; + } + } + varPtr->flags = (varPtr->flags & ~VAR_UNDEFINED) | VAR_UPVAR; + varPtr->value.upvarPtr = otherPtr; + otherPtr->refCount++; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GlobalCmd -- + * + * This procedure is invoked to process the "global" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result value. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_GlobalCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + register Interp *iPtr = (Interp *) interp; + + if (argc < 2) { + Tcl_AppendResult((Tcl_Interp *) iPtr, "wrong # args: should be \"", + argv[0], " varName ?varName ...?\"", (char *) NULL); + return TCL_ERROR; + } + if (iPtr->varFramePtr == NULL) { + return TCL_OK; + } + + for (argc--, argv++; argc > 0; argc--, argv++) { + if (MakeUpvar(iPtr, (CallFrame *) NULL, *argv, (char *) NULL, *argv) + != TCL_OK) { + return TCL_ERROR; + } + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_UpvarCmd -- + * + * This procedure is invoked to process the "upvar" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result value. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_UpvarCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + register Interp *iPtr = (Interp *) interp; + int result; + CallFrame *framePtr; + register char *p; + + if (argc < 3) { + upvarSyntax: + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " ?level? otherVar localVar ?otherVar localVar ...?\"", + (char *) NULL); + return TCL_ERROR; + } + + /* + * Find the hash table containing the variable being referenced. + */ + + result = TclGetFrame(interp, argv[1], &framePtr); + if (result == -1) { + return TCL_ERROR; + } + argc -= result+1; + if ((argc & 1) != 0) { + goto upvarSyntax; + } + argv += result+1; + + /* + * Iterate over all the pairs of (other variable, local variable) + * names. For each pair, divide the other variable name into two + * parts, then call MakeUpvar to do all the work of creating linking + * it to the local variable. + */ + + for ( ; argc > 0; argc -= 2, argv += 2) { + for (p = argv[0]; *p != 0; p++) { + if (*p == '(') { + char *open = p; + + do { + p++; + } while (*p != '\0'); + p--; + if (*p != ')') { + goto scalar; + } + *open = '\0'; + *p = '\0'; + result = MakeUpvar(iPtr, framePtr, argv[0], open+1, argv[1]); + *open = '('; + *p = ')'; + goto checkResult; + } + } + scalar: + result = MakeUpvar(iPtr, framePtr, argv[0], (char *) NULL, argv[1]); + + checkResult: + if (result != TCL_OK) { + return TCL_ERROR; + } + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * CallTraces -- + * + * This procedure is invoked to find and invoke relevant + * trace procedures associated with a particular operation on + * a variable. This procedure invokes traces both on the + * variable and on its containing array (where relevant). + * + * Results: + * The return value is NULL if no trace procedures were invoked, or + * if all the invoked trace procedures returned successfully. + * The return value is non-zero if a trace procedure returned an + * error (in this case no more trace procedures were invoked after + * the error was returned). In this case the return value is a + * pointer to a static string describing the error. + * + * Side effects: + * Almost anything can happen, depending on trace; this procedure + * itself doesn't have any side effects. + * + *---------------------------------------------------------------------- + */ + +static char * +CallTraces(iPtr, arrayPtr, varPtr, part1, part2, flags) + Interp *iPtr; /* Interpreter containing variable. */ + register Var *arrayPtr; /* Pointer to array variable that + * contains the variable, or NULL if + * the variable isn't an element of an + * array. */ + Var *varPtr; /* Variable whose traces are to be + * invoked. */ + char *part1, *part2; /* Variable's two-part name. */ + int flags; /* Flags to pass to trace procedures: + * indicates what's happening to + * variable, plus other stuff like + * TCL_GLOBAL_ONLY and + * TCL_INTERP_DESTROYED. */ +{ + register VarTrace *tracePtr; + ActiveVarTrace active; + char *result; + + /* + * If there are already similar trace procedures active for the + * variable, don't call them again. + */ + + if (varPtr->flags & VAR_TRACE_ACTIVE) { + return NULL; + } + varPtr->flags |= VAR_TRACE_ACTIVE; + varPtr->refCount++; + + /* + * Invoke traces on the array containing the variable, if relevant. + */ + + result = NULL; + active.nextPtr = iPtr->activeTracePtr; + iPtr->activeTracePtr = &active; + if (arrayPtr != NULL) { + arrayPtr->refCount++; + active.varPtr = arrayPtr; + for (tracePtr = arrayPtr->tracePtr; tracePtr != NULL; + tracePtr = active.nextTracePtr) { + active.nextTracePtr = tracePtr->nextPtr; + if (!(tracePtr->flags & flags)) { + continue; + } + result = (*tracePtr->traceProc)(tracePtr->clientData, + (Tcl_Interp *) iPtr, part1, part2, flags); + if (result != NULL) { + if (flags & TCL_TRACE_UNSETS) { + result = NULL; + } else { + goto done; + } + } + } + } + + /* + * Invoke traces on the variable itself. + */ + + if (flags & TCL_TRACE_UNSETS) { + flags |= TCL_TRACE_DESTROYED; + } + active.varPtr = varPtr; + for (tracePtr = varPtr->tracePtr; tracePtr != NULL; + tracePtr = active.nextTracePtr) { + active.nextTracePtr = tracePtr->nextPtr; + if (!(tracePtr->flags & flags)) { + continue; + } + result = (*tracePtr->traceProc)(tracePtr->clientData, + (Tcl_Interp *) iPtr, part1, part2, flags); + if (result != NULL) { + if (flags & TCL_TRACE_UNSETS) { + result = NULL; + } else { + goto done; + } + } + } + + /* + * Restore the variable's flags, remove the record of our active + * traces, and then return. + */ + + done: + if (arrayPtr != NULL) { + arrayPtr->refCount--; + } + varPtr->flags &= ~VAR_TRACE_ACTIVE; + varPtr->refCount--; + iPtr->activeTracePtr = active.nextPtr; + return result; +} + +/* + *---------------------------------------------------------------------- + * + * NewVar -- + * + * Create a new variable with a given amount of storage + * space. + * + * Results: + * The return value is a pointer to the new variable structure. + * The variable will not be part of any hash table yet. Its + * initial value is empty. + * + * Side effects: + * Storage gets allocated. + * + *---------------------------------------------------------------------- + */ + +static Var * +NewVar() +{ + register Var *varPtr; + + varPtr = (Var *) ckalloc(sizeof(Var)); + varPtr->valueLength = 0; + varPtr->valueSpace = 0; + varPtr->value.string = NULL; + varPtr->hPtr = NULL; + varPtr->refCount = 0; + varPtr->tracePtr = NULL; + varPtr->searchPtr = NULL; + varPtr->flags = VAR_UNDEFINED; + return varPtr; +} + +/* + *---------------------------------------------------------------------- + * + * ParseSearchId -- + * + * This procedure translates from a string to a pointer to an + * active array search (if there is one that matches the string). + * + * Results: + * The return value is a pointer to the array search indicated + * by string, or NULL if there isn't one. If NULL is returned, + * interp->result contains an error message. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static ArraySearch * +ParseSearchId(interp, varPtr, varName, string) + Tcl_Interp *interp; /* Interpreter containing variable. */ + Var *varPtr; /* Array variable search is for. */ + char *varName; /* Name of array variable that search is + * supposed to be for. */ + char *string; /* String containing id of search. Must have + * form "search-num-var" where "num" is a + * decimal number and "var" is a variable + * name. */ +{ + char *end; + int id; + ArraySearch *searchPtr; + + /* + * Parse the id into the three parts separated by dashes. + */ + + if ((string[0] != 's') || (string[1] != '-')) { + syntax: + Tcl_AppendResult(interp, "illegal search identifier \"", string, + "\"", (char *) NULL); + return NULL; + } + id = strtoul(string+2, &end, 10); + if ((end == (string+2)) || (*end != '-')) { + goto syntax; + } + if (strcmp(end+1, varName) != 0) { + Tcl_AppendResult(interp, "search identifier \"", string, + "\" isn't for variable \"", varName, "\"", (char *) NULL); + return NULL; + } + + /* + * Search through the list of active searches on the interpreter + * to see if the desired one exists. + */ + + for (searchPtr = varPtr->searchPtr; searchPtr != NULL; + searchPtr = searchPtr->nextPtr) { + if (searchPtr->id == id) { + return searchPtr; + } + } + Tcl_AppendResult(interp, "couldn't find search \"", string, "\"", + (char *) NULL); + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * DeleteSearches -- + * + * This procedure is called to free up all of the searches + * associated with an array variable. + * + * Results: + * None. + * + * Side effects: + * Memory is released to the storage allocator. + * + *---------------------------------------------------------------------- + */ + +static void +DeleteSearches(arrayVarPtr) + register Var *arrayVarPtr; /* Variable whose searches are + * to be deleted. */ +{ + ArraySearch *searchPtr; + + while (arrayVarPtr->searchPtr != NULL) { + searchPtr = arrayVarPtr->searchPtr; + arrayVarPtr->searchPtr = searchPtr->nextPtr; + ckfree((char *) searchPtr); + } +} + +/* + *---------------------------------------------------------------------- + * + * TclDeleteVars -- + * + * This procedure is called to recycle all the storage space + * associated with a table of variables. For this procedure + * to work correctly, it must not be possible for any of the + * variable in the table to be accessed from Tcl commands + * (e.g. from trace procedures). + * + * Results: + * None. + * + * Side effects: + * Variables are deleted and trace procedures are invoked, if + * any are declared. + * + *---------------------------------------------------------------------- + */ + +void +TclDeleteVars(iPtr, tablePtr) + Interp *iPtr; /* Interpreter to which variables belong. */ + Tcl_HashTable *tablePtr; /* Hash table containing variables to + * delete. */ +{ + Tcl_HashSearch search; + Tcl_HashEntry *hPtr; + register Var *varPtr; + Var *upvarPtr; + int flags; + ActiveVarTrace *activePtr; + + flags = TCL_TRACE_UNSETS; + if (tablePtr == &iPtr->globalTable) { + flags |= TCL_INTERP_DESTROYED | TCL_GLOBAL_ONLY; + } + for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL; + hPtr = Tcl_NextHashEntry(&search)) { + varPtr = (Var *) Tcl_GetHashValue(hPtr); + + /* + * For global/upvar variables referenced in procedures, decrement + * the reference count on the variable referred to, and free up + * the referenced variable if it's no longer needed. + */ + + if (varPtr->flags & VAR_UPVAR) { + upvarPtr = varPtr->value.upvarPtr; + upvarPtr->refCount--; + if (upvarPtr->flags & VAR_UNDEFINED) { + CleanupVar(upvarPtr, (Var *) NULL); + } + } + + /* + * Invoke traces on the variable that is being deleted, then + * free up the variable's space (no need to free the hash entry + * here, unless we're dealing with a global variable: the + * hash entries will be deleted automatically when the whole + * table is deleted). + */ + + if (varPtr->tracePtr != NULL) { + (void) CallTraces(iPtr, (Var *) NULL, varPtr, + Tcl_GetHashKey(tablePtr, hPtr), (char *) NULL, flags); + while (varPtr->tracePtr != NULL) { + VarTrace *tracePtr = varPtr->tracePtr; + varPtr->tracePtr = tracePtr->nextPtr; + ckfree((char *) tracePtr); + } + for (activePtr = iPtr->activeTracePtr; activePtr != NULL; + activePtr = activePtr->nextPtr) { + if (activePtr->varPtr == varPtr) { + activePtr->nextTracePtr = NULL; + } + } + } + if (varPtr->flags & VAR_ARRAY) { + DeleteArray(iPtr, Tcl_GetHashKey(tablePtr, hPtr), varPtr, flags); + } + if (varPtr->valueSpace > 0) { + /* + * SPECIAL TRICK: it's possible that the interpreter's result + * currently points to this variable (for example, a "set" or + * "lappend" command was the last command in a procedure that's + * being returned from). If this is the case, then just pass + * ownership of the value string to the Tcl interpreter. + */ + + if (iPtr->result == varPtr->value.string) { + iPtr->freeProc = (Tcl_FreeProc *) free; + } else { + ckfree(varPtr->value.string); + } + varPtr->valueSpace = 0; + } + varPtr->hPtr = NULL; + varPtr->tracePtr = NULL; + varPtr->flags = VAR_UNDEFINED; + if (varPtr->refCount == 0) { + ckfree((char *) varPtr); + } + } + Tcl_DeleteHashTable(tablePtr); +} + +/* + *---------------------------------------------------------------------- + * + * DeleteArray -- + * + * This procedure is called to free up everything in an array + * variable. It's the caller's responsibility to make sure + * that the array is no longer accessible before this procedure + * is called. + * + * Results: + * None. + * + * Side effects: + * All storage associated with varPtr's array elements is deleted + * (including the hash table). Delete trace procedures for + * array elements are invoked. + * + *---------------------------------------------------------------------- + */ + +static void +DeleteArray(iPtr, arrayName, varPtr, flags) + Interp *iPtr; /* Interpreter containing array. */ + char *arrayName; /* Name of array (used for trace + * callbacks). */ + Var *varPtr; /* Pointer to variable structure. */ + int flags; /* Flags to pass to CallTraces: + * TCL_TRACE_UNSETS and sometimes + * TCL_INTERP_DESTROYED and/or + * TCL_GLOBAL_ONLY. */ +{ + Tcl_HashSearch search; + register Tcl_HashEntry *hPtr; + register Var *elPtr; + ActiveVarTrace *activePtr; + + DeleteSearches(varPtr); + for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search); + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + elPtr = (Var *) Tcl_GetHashValue(hPtr); + if (elPtr->valueSpace != 0) { + /* + * SPECIAL TRICK: it's possible that the interpreter's result + * currently points to this element (for example, a "set" or + * "lappend" command was the last command in a procedure that's + * being returned from). If this is the case, then just pass + * ownership of the value string to the Tcl interpreter. + */ + + if (iPtr->result == elPtr->value.string) { + iPtr->freeProc = (Tcl_FreeProc *) free; + } else { + ckfree(elPtr->value.string); + } + elPtr->valueSpace = 0; + } + elPtr->hPtr = NULL; + if (elPtr->tracePtr != NULL) { + elPtr->flags &= ~VAR_TRACE_ACTIVE; + (void) CallTraces(iPtr, (Var *) NULL, elPtr, arrayName, + Tcl_GetHashKey(varPtr->value.tablePtr, hPtr), flags); + while (elPtr->tracePtr != NULL) { + VarTrace *tracePtr = elPtr->tracePtr; + elPtr->tracePtr = tracePtr->nextPtr; + ckfree((char *) tracePtr); + } + for (activePtr = iPtr->activeTracePtr; activePtr != NULL; + activePtr = activePtr->nextPtr) { + if (activePtr->varPtr == elPtr) { + activePtr->nextTracePtr = NULL; + } + } + } + elPtr->flags = VAR_UNDEFINED; + if (elPtr->refCount == 0) { + ckfree((char *) elPtr); + } + } + Tcl_DeleteHashTable(varPtr->value.tablePtr); + ckfree((char *) varPtr->value.tablePtr); +} + +/* + *---------------------------------------------------------------------- + * + * CleanupVar -- + * + * This procedure is called when it looks like it may be OK + * to free up the variable's record and hash table entry, and + * those of its containing parent. It's called, for example, + * when a trace on a variable deletes the variable. + * + * Results: + * None. + * + * Side effects: + * If the variable (or its containing array) really is dead then + * its record, and possibly its hash table entry, gets freed up. + * + *---------------------------------------------------------------------- + */ + +static void +CleanupVar(varPtr, arrayPtr) + Var *varPtr; /* Pointer to variable that may be a + * candidate for being expunged. */ + Var *arrayPtr; /* Array that contains the variable, or + * NULL if this variable isn't an array + * element. */ +{ + if ((varPtr->flags & VAR_UNDEFINED) && (varPtr->refCount == 0) + && (varPtr->tracePtr == NULL)) { + if (varPtr->hPtr != NULL) { + Tcl_DeleteHashEntry(varPtr->hPtr); + } + ckfree((char *) varPtr); + } + if (arrayPtr != NULL) { + if ((arrayPtr->flags & VAR_UNDEFINED) && (arrayPtr->refCount == 0) + && (arrayPtr->tracePtr == NULL)) { + if (arrayPtr->hPtr != NULL) { + Tcl_DeleteHashEntry(arrayPtr->hPtr); + } + ckfree((char *) arrayPtr); + } + } + return; +} + +/* + *---------------------------------------------------------------------- + * + * VarErrMsg -- + * + * Generate a reasonable error message describing why a variable + * operation failed. + * + * Results: + * None. + * + * Side effects: + * Interp->result is reset to hold a message identifying the + * variable given by part1 and part2 and describing why the + * variable operation failed. + * + *---------------------------------------------------------------------- + */ + +static void +VarErrMsg(interp, part1, part2, operation, reason) + Tcl_Interp *interp; /* Interpreter in which to record message. */ + char *part1, *part2; /* Variable's two-part name. */ + char *operation; /* String describing operation that failed, + * e.g. "read", "set", or "unset". */ + char *reason; /* String describing why operation failed. */ +{ + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "can't ", operation, " \"", part1, (char *) NULL); + if (part2 != NULL) { + Tcl_AppendResult(interp, "(", part2, ")", (char *) NULL); + } + Tcl_AppendResult(interp, "\": ", reason, (char *) NULL); +} diff --git a/vendor/x11iraf/obm/Tcl/tests/README b/vendor/x11iraf/obm/Tcl/tests/README new file mode 100644 index 00000000..593174a5 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/tests/README @@ -0,0 +1,93 @@ +Tcl Test Suite +-------------- + +This directory contains a set of validation tests for the Tcl +commands. Each of the files whose name ends in ".test" is +intended to fully exercise one or a few Tcl commands. The +commands tested by a given file are listed in the first line +of the file. + +You can run the tests in two ways: + (a) type "make test" in the parent directory to this one; this + will run all of the tests. + (b) start up tcltest in this directory, then "source" the test + file (for example, type "source parse.test"). To run all + of the tests, type "source all". +In either case no output will be generated if all goes well, except +for a listing of the tests.. If there are errors then additional +messages will appear in the format described below. + +The rest of this file provides additional information on the +features of the testing environment. + +This approach to testing was designed and initially implemented +by Mary Ann May-Pumphrey of Sun Microsystems. Many thanks to +her for donating her work back to the public Tcl release. + +Definitions file: +----------------- + +The file "defs" defines a collection of procedures and variables +used to run the tests. It is read in automatically by each of the +.test files if needed, but once it has been read once it will not +be read again by the .test files. If you change defs while running +tests you'll have to "source" it by hand to load its new contents. + +Test output: +------------ + +Normally, output only appears when there are errors. However, if +the variable VERBOSE is set to 1 then tests will be run in "verbose" +mode and output will be generated for each test regardless of +whether it succeeded or failed. Test output consists of the +following information: + + - the test identifier (which can be used to locate the test code + in the .test file) + - a brief description of the test + - the contents of the test code + - the actual results produced by the tests + - a "PASSED" or "FAILED" message + - the expected results (if the test failed) + +You can set VERBOSE either interactively (after the defs file has been +read in), or you can change the default value in "defs". + +Selecting tests for execution: +------------------------------ + +Normally, all the tests in a file are run whenever the file is +"source"d. However, you can select a specific set of tests using +the global variable TESTS. This variable contains a pattern; any +test whose identifier matches TESTS will be run. For example, +the following interactive command causes all of the "for" tests in +groups 2 and 4 to be executed: + + set TESTS {for-[24]*} + +TESTS defaults to *, but you can change the default in "defs" if +you wish. + +Saving keystrokes: +------------------ + +A convenience procedure named "dotests" is included in file +"defs". It takes two arguments--the name of the test file (such +as "parse.test"), and a pattern selecting the tests you want to +execute. It sets TESTS to the second argument, calls "source" on +the file specified in the first argument, and restores TESTS to +its pre-call value at the end. + +Batch vs. interactive execution: +-------------------------------- + +The tests can be run in either batch or interactive mode. Batch +mode refers to using I/O redirection from a UNIX shell. For example, +the following command causes the tests in the file named "parse.test" +to be executed: + + tclTest < parse.test > parse.test.results + +Users who want to execute the tests in this fashion need to first +ensure that the file "defs" has proper values for the global +variables that control the testing environment (VERBOSE and TESTS). diff --git a/vendor/x11iraf/obm/Tcl/tests/all b/vendor/x11iraf/obm/Tcl/tests/all new file mode 100644 index 00000000..890e9a2d --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/tests/all @@ -0,0 +1,10 @@ +# This file contains a top-level script to run all of the Tcl +# tests. Execute it by invoking "source all" when running tclTest +# in this directory. +# +# $Header: /sprite/src/lib/tcl/tests/RCS/all,v 1.4 91/09/08 13:43:07 ouster Exp $ (Berkeley) + +foreach i [lsort [glob *.test]] { + puts stdout $i + source $i +} diff --git a/vendor/x11iraf/obm/Tcl/tests/append.test b/vendor/x11iraf/obm/Tcl/tests/append.test new file mode 100644 index 00000000..e7f86b5c --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/tests/append.test @@ -0,0 +1,122 @@ +# Commands covered: append lappend +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1991-1993 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. +# +# $Header: /user6/ouster/tcl/tests/RCS/append.test,v 1.6 93/06/19 14:28:25 ouster Exp $ (Berkeley) + +if {[string compare test [info procs test]] == 1} then {source defs} + +catch {unset x} +test append-1.1 {append command} { + catch {unset x} + list [append x 1 2 abc "long string"] $x +} {{12abclong string} {12abclong string}} +test append-1.2 {append command} { + set x "" + list [append x first] [append x second] [append x third] $x +} {first firstsecond firstsecondthird firstsecondthird} + +test append-2.1 {long appends} { + set x "" + for {set i 0} {$i < 1000} {set i [expr $i+1]} { + append x "foobar " + } + set y "foobar" + set y "$y $y $y $y $y $y $y $y $y $y" + set y "$y $y $y $y $y $y $y $y $y $y" + set y "$y $y $y $y $y $y $y $y $y $y " + expr {$x == $y} +} 1 + +test append-3.1 {append errors} { + list [catch {append} msg] $msg +} {1 {wrong # args: should be "append varName value ?value ...?"}} +test append-3.2 {append errors} { + list [catch {append x} msg] $msg +} {1 {wrong # args: should be "append varName value ?value ...?"}} +test append-3.3 {append errors} { + set x "" + list [catch {append x(0) 44} msg] $msg +} {1 {can't set "x(0)": variable isn't array}} + +test append-4.1 {lappend command} { + catch {unset x} + list [lappend x 1 2 abc "long string"] $x +} {{1 2 abc {long string}} {1 2 abc {long string}}} +test append-4.2 {lappend command} { + set x "" + list [lappend x first] [lappend x second] [lappend x third] $x +} {first {first second} {first second third} {first second third}} +test append-4.3 {lappend command} { + proc foo {} { + global x + set x old + unset x + lappend x new + } + set result [foo] + rename foo {} + set result +} {new} +test append-4.3 {lappend command} { + set x {} + lappend x \{\ abc +} {\{\ abc} +test append-4.3 {lappend command} { + set x {} + lappend x \{ abc +} {\{ abc} + +proc check {var size} { + set l [llength $var] + if {$l != $size} { + return "length mismatch: should have been $size, was $l" + } + for {set i 0} {$i < $size} {set i [expr $i+1]} { + set j [lindex $var $i] + if {$j != "item $i"} { + return "element $i should have been \"item $i\", was \"$j\" + } + } + return ok +} +test append-5.1 {long lappends} { + set x "" + for {set i 0} {$i < 300} {set i [expr $i+1]} { + lappend x "item $i" + } + check $x 300 +} ok + +test append-6.1 {lappend errors} { + list [catch {lappend} msg] $msg +} {1 {wrong # args: should be "lappend varName value ?value ...?"}} +test append-6.2 {lappend errors} { + list [catch {lappend x} msg] $msg +} {1 {wrong # args: should be "lappend varName value ?value ...?"}} +test append-6.3 {lappend errors} { + set x "" + list [catch {lappend x(0) 44} msg] $msg +} {1 {can't set "x(0)": variable isn't array}} diff --git a/vendor/x11iraf/obm/Tcl/tests/async.test b/vendor/x11iraf/obm/Tcl/tests/async.test new file mode 100644 index 00000000..dc11c24d --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/tests/async.test @@ -0,0 +1,145 @@ +# Commands covered: none +# +# This file contains a collection of tests for Tcl_AsyncCreate and related +# library procedures. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1993 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. +# +# $Header: /user6/ouster/tcl/tests/RCS/async.test,v 1.2 93/08/14 17:07:43 ouster Exp $ (Berkeley) + +if {[info commands testasync] == {}} { + puts "This application hasn't been compiled with the \"testasync\"" + puts "command, so I can't test Tcl_AsyncCreate et al." + return +} + +if {[string compare test [info procs test]] == 1} then {source defs} + +proc async1 {result code} { + global aresult acode + set aresult $result + set acode $code + return "new result" +} +proc async2 {result code} { + global aresult acode + set aresult $result + set acode $code + return -code error "xyzzy" +} +proc async3 {result code} { + global aresult + set aresult "test pattern" + return -code $code $result +} + +set handler1 [testasync create async1] +set handler2 [testasync create async2] +set handler3 [testasync create async3] +test async-1.1 {basic async handlers} { + set aresult xxx + set acode yyy + list [catch {testasync mark $handler1 "original" 0} msg] $msg \ + $acode $aresult +} {0 {new result} 0 original} +test async-1.2 {basic async handlers} { + set aresult xxx + set acode yyy + list [catch {testasync mark $handler1 "original" 1} msg] $msg \ + $acode $aresult +} {0 {new result} 1 original} +test async-1.3 {basic async handlers} { + set aresult xxx + set acode yyy + list [catch {testasync mark $handler2 "old" 0} msg] $msg \ + $acode $aresult +} {1 xyzzy 0 old} +test async-1.4 {basic async handlers} { + set aresult xxx + set acode yyy + list [catch {testasync mark $handler2 "old" 3} msg] $msg \ + $acode $aresult +} {1 xyzzy 3 old} +test async-1.5 {basic async handlers} { + set aresult xxx + list [catch {testasync mark $handler3 "foobar" 0} msg] $msg $aresult +} {0 foobar {test pattern}} +test async-1.6 {basic async handlers} { + set aresult xxx + list [catch {testasync mark $handler3 "foobar" 1} msg] $msg $aresult +} {1 foobar {test pattern}} + +proc mult1 {result code} { + global x + lappend x mult1 + return -code 7 mult1 +} +set hm1 [testasync create mult1] +proc mult2 {result code} { + global x + lappend x mult2 + return -code 9 mult2 +} +set hm2 [testasync create mult2] +proc mult3 {result code} { + global x hm1 hm2 + lappend x [catch {testasync mark $hm2 serial2 0}] + lappend x [catch {testasync mark $hm1 serial1 0}] + lappend x mult3 + return -code 11 mult3 +} +set hm3 [testasync create mult3] + +test async-2.1 {multiple handlers} { + set x {} + list [catch {testasync mark $hm3 "foobar" 5} msg] $msg $x +} {9 mult2 {0 0 mult3 mult1 mult2}} + +proc del1 {result code} { + global x hm1 hm2 hm3 hm4 + lappend x [catch {testasync mark $hm3 serial2 0}] + lappend x [catch {testasync mark $hm1 serial1 0}] + lappend x [catch {testasync mark $hm4 serial1 0}] + testasync delete $hm1 + testasync delete $hm2 + testasync delete $hm3 + lappend x del1 + return -code 13 del1 +} +proc del2 {result code} { + global x + lappend x del2 + return -code 3 del2 +} +testasync delete $handler1 +testasync delete $hm2 +testasync delete $hm3 +set hm2 [testasync create del1] +set hm3 [testasync create mult2] +set hm4 [testasync create del2] + +test async-3.1 {deleting handlers} { + set x {} + list [catch {testasync mark $hm2 "foobar" 5} msg] $msg $x +} {3 del2 {0 0 0 del1 del2}} + +testasync delete diff --git a/vendor/x11iraf/obm/Tcl/tests/case.test b/vendor/x11iraf/obm/Tcl/tests/case.test new file mode 100644 index 00000000..6b1cb4a6 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/tests/case.test @@ -0,0 +1,126 @@ +# Commands covered: case +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1991-1993 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. +# +# $Header: /user6/ouster/tcl/tests/RCS/case.test,v 1.11 93/06/17 11:22:41 ouster Exp $ (Berkeley) + +if {[string compare test [info procs test]] == 1} then {source defs} +# Commands covered: case +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1991-1993 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. +# +# $Header: /user6/ouster/tcl/tests/RCS/case.test,v 1.11 93/06/17 11:22:41 ouster Exp $ (Berkeley) + +if {[string compare test [info procs test]] == 1} then {source defs} + +test case-1.1 {simple pattern} { + case a in a {format 1} b {format 2} c {format 3} default {format 4} +} 1 +test case-1.2 {simple pattern} { + case b a {format 1} b {format 2} c {format 3} default {format 4} +} 2 +test case-1.3 {simple pattern} { + case x in a {format 1} b {format 2} c {format 3} default {format 4} +} 4 +test case-1.4 {simple pattern} { + case x a {format 1} b {format 2} c {format 3} +} {} +test case-1.5 {simple pattern matches many times} { + case b a {format 1} b {format 2} b {format 3} b {format 4} +} 2 +test case-1.6 {fancier pattern} { + case cx a {format 1} *c {format 2} *x {format 3} default {format 4} +} 3 +test case-1.7 {list of patterns} { + case abc in {a b c} {format 1} {def abc ghi} {format 2} +} 2 + +test case-2.1 {error in executed command} { + list [catch {case a in a {error "Just a test"} default {format 1}} msg] \ + $msg $errorInfo +} {1 {Just a test} {Just a test + while executing +"error "Just a test"" + ("a" arm line 1) + invoked from within +"case a in a {error "Just a test"} default {format 1}"}} +test case-2.2 {error: not enough args} { + list [catch {case} msg] $msg +} {1 {wrong # args: should be "case string ?in? patList body ... ?default body?"}} +test case-2.3 {error: pattern with no body} { + list [catch {case a b} msg] $msg +} {1 {extra case pattern with no body}} +test case-2.4 {error: pattern with no body} { + list [catch {case a in b {format 1} c} msg] $msg +} {1 {extra case pattern with no body}} +test case-2.5 {error in default command} { + list [catch {case foo in a {error case1} default {error case2} \ + b {error case 3}} msg] $msg $errorInfo +} {1 case2 {case2 + while executing +"error case2" + ("default" arm line 1) + invoked from within +"case foo in a {error case1} default {error case2} b {error case 3}"}} + +test case-3.1 {single-argument form for pattern/command pairs} { + case b in { + a {format 1} + b {format 2} + default {format 6} + } +} {2} +test case-3.2 {single-argument form for pattern/command pairs} { + case b { + a {format 1} + b {format 2} + default {format 6} + } +} {2} +test case-3.3 {single-argument form for pattern/command pairs} { + list [catch {case z in {a 2 b}} msg] $msg +} {1 {extra case pattern with no body}} diff --git a/vendor/x11iraf/obm/Tcl/tests/cd.test b/vendor/x11iraf/obm/Tcl/tests/cd.test new file mode 100644 index 00000000..d1eb3357 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/tests/cd.test @@ -0,0 +1,121 @@ +# Commands covered: cd, pwd +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1991-1993 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. +# +# $Header: /user6/ouster/tcl/tests/RCS/cd.test,v 1.21 93/10/07 17:21:21 ouster Exp $ (Berkeley) + +if {[string compare test [info procs test]] == 1} then {source defs} + +catch {exec rm -rf cd.dir} +exec mkdir cd.dir +exec cat << "Sample text" > cd.dir/test.file +set cwd [exec pwd] + +test cd-1.1 {simple pwd check} { + pwd +} $cwd + +cd cd.dir +if $atBerkeley { + test cd-2.1 {changing directories} { + list [exec pwd] + } $cwd/cd.dir + test cd-2.2 {changing directories} { + pwd + } $cwd/cd.dir +} +test cd-2.3 {changing directories} { + exec cat test.file +} "Sample text" +cd .. +test cd-2.4 {changing directories} { + exec pwd +} $cwd +test cd-2.5 {changing directories} { + pwd +} $cwd +test cd-2.6 {changing directories} { + exec cat cd.dir/test.file +} "Sample text" + +# The tests below seem to fail on lots of machines for a variety +# of reasons, such as the auto-mounter, home directories that are +# symbolic links, etc. + +if $atBerkeley { + set home [exec sh -c "cd; pwd"] + test cd-2.7 {changing directories} { + cd ~ + set x [list [exec pwd] [pwd]] + cd $cwd + set x + } "$home $home" + test cd-2.8 {changing directories} { + cd + set x [list [exec pwd] [pwd]] + cd $cwd + set x + } "$home $home" +} + +test cd-3.1 {cd return value} { + cd . +} {} + +test cd-4.1 {errors in cd command} { + list [catch {cd 1 2} msg] $msg $errorCode +} {1 {wrong # args: should be "cd dirName"} NONE} +test cd-4.2 {errors in cd command} { + string tolower [list [catch {cd _bad_dir} msg] $msg $errorCode] +} {1 {couldn't change working directory to "_bad_dir": no such file or directory} {posix enoent {no such file or directory}}} +test cd-4.3 {errors in cd command} { + string tolower [list [catch {cd cd.dir/test.file} msg] $msg $errorCode] +} {1 {couldn't change working directory to "cd.dir/test.file": not a directory} {posix enotdir {not a directory}}} +test cd-4.4 {errors in cd command} { + set home $env(HOME) + unset env(HOME) + set x [list [catch cd msg] $msg] + set env(HOME) $home + set x +} {1 {couldn't find HOME environment variable to expand "~"}} + +test cd-5.1 {errors in pwd command} { + list [catch {pwd a} msg] $msg +} {1 {wrong # args: should be "pwd"}} +if $atBerkeley { + exec mkdir cd.dir/child + cd cd.dir/child + exec chmod 111 .. + if {$user != "root"} { + test cd-5.2 {errors in pwd command} { + catch pwd msg + } 1 + } + cd $cwd + exec chmod 775 cd.dir +} + +catch {exec rm -rf cd.dir} +format "" diff --git a/vendor/x11iraf/obm/Tcl/tests/cmdinfo.test b/vendor/x11iraf/obm/Tcl/tests/cmdinfo.test new file mode 100644 index 00000000..8998363d --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/tests/cmdinfo.test @@ -0,0 +1,79 @@ +# Commands covered: none +# +# This file contains a collection of tests for Tcl_GetCommandInfo, +# Tcl_SetCommandInfo, Tcl_CreateCommand, and Tcl_DeleteCommand. +# Sourcing this file into Tcl runs the tests and generates output for +# errors. No output means no errors were found. +# +# Copyright (c) 1993 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. +# +# $Header: /user6/ouster/tcl/tests/RCS/cmdinfo.test,v 1.1 93/07/01 16:23:09 ouster Exp $ (Berkeley) + +if {[info commands testcmdinfo] == {}} { + puts "This application hasn't been compiled with the \"testcmdinfo\"" + puts "command, so I can't test Tcl_GetCommandInfo etc." + return +} + +if {[string compare test [info procs test]] == 1} then {source defs} + +test cmdinfo-1.1 {command procedure and clientData} { + testcmdinfo create x1 + testcmdinfo get x1 +} {CmdProc1 original CmdDelProc1 original} +test cmdinfo-1.2 {command procedure and clientData} { + testcmdinfo create x1 + x1 +} {CmdProc1 original} +test cmdinfo-1.3 {command procedure and clientData} { + testcmdinfo create x1 + testcmdinfo modify x1 + testcmdinfo get x1 +} {CmdProc2 new_command_data CmdDelProc2 new_delete_data} +test cmdinfo-1.4 {command procedure and clientData} { + testcmdinfo create x1 + testcmdinfo modify x1 + x1 +} {CmdProc2 new_command_data} + +test cmdinfo-2.1 {command deletion callbacks} { + testcmdinfo create x1 + testcmdinfo delete x1 +} {CmdDelProc1 original} +test cmdinfo-2.2 {command deletion callbacks} { + testcmdinfo create x1 + testcmdinfo modify x1 + testcmdinfo delete x1 +} {CmdDelProc2 new_delete_data} + +test cmdinfo-3.1 {Tcl_Get/SetCommandInfo return values} { + testcmdinfo get non_existent +} {??} +test cmdinfo-3.2 {Tcl_Get/SetCommandInfo return values} { + testcmdinfo create x1 + testcmdinfo modify x1 +} 1 +test cmdinfo-3.3 {Tcl_Get/SetCommandInfo return values} { + testcmdinfo modify non_existent +} 0 + +catch {rename x1 ""} +concat {} diff --git a/vendor/x11iraf/obm/Tcl/tests/concat.test b/vendor/x11iraf/obm/Tcl/tests/concat.test new file mode 100644 index 00000000..a758765d --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/tests/concat.test @@ -0,0 +1,53 @@ +# Commands covered: concat +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1991-1993 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. +# +# $Header: /user6/ouster/tcl/tests/RCS/concat.test,v 1.6 93/10/28 16:13:57 ouster Exp $ (Berkeley) + +if {[string compare test [info procs test]] == 1} then {source defs} + +test concat-1.1 {simple concatenation} { + concat a b c d e f g +} {a b c d e f g} +test concat-1.2 {merging lists together} { + concat a {b c d} {e f g h} +} {a b c d e f g h} +test concat-1.3 {merge lists, retain sub-lists} { + concat a {b {c d}} {{e f}} g h +} {a b {c d} {e f} g h} +test concat-1.4 {special characters} { + concat a\{ {b \{c d} \{d +} "a{ b \\{c d {d" + +test concat-2.1 {error: no arguments} { + list [catch concat msg] $msg +} {0 {}} + +test concat-3.1 {pruning off extra white space} { + concat {} {a b c} +} {a b c} +test concat-3.2 {pruning off extra white space} { + concat x y " a b c \n\t " " " " def " +} {x y a b c def} diff --git a/vendor/x11iraf/obm/Tcl/tests/dcall.test b/vendor/x11iraf/obm/Tcl/tests/dcall.test new file mode 100644 index 00000000..a54d7191 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/tests/dcall.test @@ -0,0 +1,54 @@ +# Commands covered: none +# +# This file contains a collection of tests for Tcl_CallWhenDeleted. +# Sourcing this file into Tcl runs the tests and generates output for +# errors. No output means no errors were found. +# +# Copyright (c) 1993 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. +# +# $Header: /user6/ouster/tcl/tests/RCS/dcall.test,v 1.3 93/09/09 16:43:05 ouster Exp $ (Berkeley) + +if {[info commands testdcall] == {}} { + puts "This application hasn't been compiled with the \"testdcall\"" + puts "command, so I can't test Tcl_CallWhenDeleted." + return +} + +if {[string compare test [info procs test]] == 1} then {source defs} + +test dcall-1.1 {deletion callbacks} { + testdcall 1 2 3 +} {1 2 3} +test dcall-1.2 {deletion callbacks} { + testdcall +} {} +test dcall-1.3 {deletion callbacks} { + testdcall 20 21 22 -22 +} {20 21} +test dcall-1.4 {deletion callbacks} { + testdcall 20 21 22 -20 +} {21 22} +test dcall-1.5 {deletion callbacks} { + testdcall 20 21 22 -21 +} {20 22} +test dcall-1.6 {deletion callbacks} { + testdcall 20 21 22 -21 -22 -20 +} {} diff --git a/vendor/x11iraf/obm/Tcl/tests/defs b/vendor/x11iraf/obm/Tcl/tests/defs new file mode 100644 index 00000000..63f24404 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/tests/defs @@ -0,0 +1,94 @@ +# This file contains support code for the Tcl test suite. It is +# normally sourced by the individual files in the test suite before +# they run their tests. This improved approach to testing was designed +# and initially implemented by Mary Ann May-Pumphrey of Sun Microsystems. + +set VERBOSE 0 +set TESTS {} +set auto_noexec 1 +set auto_noload 1 +catch {rename unknown ""} + +# If tests are being run as root, issue a warning message and set a +# variable to prevent some tests from running at all. + +set user {} +catch {set user [exec whoami]} +if {$user == "root"} { + puts stdout "Warning: you're executing as root. I'll have to" + puts stdout "skip some of the tests, since they'll fail as root." +} + +# Some of the tests don't work on some system configurations due to +# configuration quirks, not due to Tcl problems; in order to prevent +# false alarms, these tests are only run in the master source directory +# at Berkeley. The presence of a file "Berkeley" in this directory is +# used to indicate that these tests should be run. + +set atBerkeley [file exists Berkeley] + +proc print_verbose {test_name test_description contents_of_test code answer} { + puts stdout "\n" + puts stdout "==== $test_name $test_description" + puts stdout "==== Contents of test case:" + puts stdout "$contents_of_test" + if {$code != 0} { + if {$code == 1} { + puts stdout "==== Test generated error:" + puts stdout $answer + } elseif {$code == 2} { + puts stdout "==== Test generated return exception; result was:" + puts stdout $answer + } elseif {$code == 3} { + puts stdout "==== Test generated break exception" + } elseif {$code == 4} { + puts stdout "==== Test generated continue exception" + } else { + puts stdout "==== Test generated exception $code; message was:" + puts stdout $answer + } + } else { + puts stdout "==== Result was:" + puts stdout "$answer" + } +} + +proc test {test_name test_description contents_of_test passing_results} { + global VERBOSE + global TESTS + if {[string compare $TESTS ""] != 0} then { + set ok 0 + foreach test $TESTS { + if [string match $test $test_name] then { + set ok 1 + break + } + } + if !$ok then return + } + set code [catch {uplevel $contents_of_test} answer] + if {$code != 0} { + print_verbose $test_name $test_description $contents_of_test \ + $code $answer + } elseif {[string compare $answer $passing_results] == 0} then { + if $VERBOSE then { + print_verbose $test_name $test_description $contents_of_test \ + $code $answer + puts stdout "++++ $test_name PASSED" + } + } else { + print_verbose $test_name $test_description $contents_of_test $code \ + $answer + puts stdout "---- Result should have been:" + puts stdout "$passing_results" + puts stdout "---- $test_name FAILED" + } +} + +proc dotests {file args} { + global TESTS + set savedTests $TESTS + set TESTS $args + source $file + set TESTS $savedTests +} diff --git a/vendor/x11iraf/obm/Tcl/tests/dstring.test b/vendor/x11iraf/obm/Tcl/tests/dstring.test new file mode 100644 index 00000000..563dc896 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/tests/dstring.test @@ -0,0 +1,192 @@ +# Commands covered: none +# +# This file contains a collection of tests for Tcl's dynamic string +# library procedures. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1993 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. +# +# $Header: /user6/ouster/tcl/tests/RCS/dstring.test,v 1.3 93/10/11 09:06:01 ouster Exp $ (Berkeley) + +if {[info commands testdstring] == {}} { + puts "This application hasn't been compiled with the \"testdstring\"" + puts "command, so I can't test Tcl_DStringAppend et al." + return +} + +if {[string compare test [info procs test]] == 1} then {source defs} + +test dstring-1.1 {appending and retrieving} { + testdstring free + testdstring append "abc" -1 + list [testdstring get] [testdstring length] +} {abc 3} +test dstring-1.2 {appending and retrieving} { + testdstring free + testdstring append "abc" -1 + testdstring append " xyzzy" 3 + testdstring append " 12345" -1 + list [testdstring get] [testdstring length] +} {{abc xy 12345} 12} +test dstring-1.3 {appending and retrieving} { + testdstring free + foreach l {a b c d e f g h i j k l m n o p} { + testdstring append $l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l\n -1 + } + list [testdstring get] [testdstring length] +} {{aaaaaaaaaaaaaaaaaaaaa +bbbbbbbbbbbbbbbbbbbbb +ccccccccccccccccccccc +ddddddddddddddddddddd +eeeeeeeeeeeeeeeeeeeee +fffffffffffffffffffff +ggggggggggggggggggggg +hhhhhhhhhhhhhhhhhhhhh +iiiiiiiiiiiiiiiiiiiii +jjjjjjjjjjjjjjjjjjjjj +kkkkkkkkkkkkkkkkkkkkk +lllllllllllllllllllll +mmmmmmmmmmmmmmmmmmmmm +nnnnnnnnnnnnnnnnnnnnn +ooooooooooooooooooooo +ppppppppppppppppppppp +} 352} + +test dstring-2.1 {appending list elements} { + testdstring free + testdstring element "abc" + testdstring element "d e f" + list [testdstring get] [testdstring length] +} {{abc {d e f}} 11} +test dstring-2.2 {appending list elements} { + testdstring free + testdstring element "x" + testdstring element "\{" + testdstring element "ab\}" + testdstring get +} {x \{ ab\}} +test dstring-2.3 {appending list elements} { + testdstring free + foreach l {a b c d e f g h i j k l m n o p} { + testdstring element $l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l + } + testdstring get +} {aaaaaaaaaaaaaaaaaaaaa bbbbbbbbbbbbbbbbbbbbb ccccccccccccccccccccc ddddddddddddddddddddd eeeeeeeeeeeeeeeeeeeee fffffffffffffffffffff ggggggggggggggggggggg hhhhhhhhhhhhhhhhhhhhh iiiiiiiiiiiiiiiiiiiii jjjjjjjjjjjjjjjjjjjjj kkkkkkkkkkkkkkkkkkkkk lllllllllllllllllllll mmmmmmmmmmmmmmmmmmmmm nnnnnnnnnnnnnnnnnnnnn ooooooooooooooooooooo ppppppppppppppppppppp} + +test dstring-3.1 {nested sublists} { + testdstring free + testdstring start + testdstring element foo + testdstring element bar + testdstring end + testdstring element another + testdstring get +} {{foo bar} another} +test dstring-3.2 {nested sublists} { + testdstring free + testdstring start + testdstring start + testdstring element abc + testdstring element def + testdstring end + testdstring end + testdstring element ghi + testdstring get +} {{{abc def}} ghi} +test dstring-3.3 {nested sublists} { + testdstring free + testdstring start + testdstring start + testdstring start + testdstring element foo + testdstring element foo2 + testdstring end + testdstring end + testdstring element foo3 + testdstring end + testdstring element foo4 + testdstring get +} {{{{foo foo2}} foo3} foo4} +test dstring-3.4 {nested sublists} { + testdstring free + testdstring element before + testdstring start + testdstring element during + testdstring element more + testdstring end + testdstring element last + testdstring get +} {before {during more} last} +test dstring-3.4 {nested sublists} { + testdstring free + testdstring element "\{" + testdstring start + testdstring element first + testdstring element second + testdstring end + testdstring get +} {\{ {first second}} + +test dstring-4.1 {truncation} { + testdstring free + testdstring append "abcdefg" -1 + testdstring trunc 3 + list [testdstring get] [testdstring length] +} {abc 3} +test dstring-4.2 {truncation} { + testdstring free + testdstring append "xyzzy" -1 + testdstring trunc 0 + list [testdstring get] [testdstring length] +} {{} 0} + +test dstring-5.1 {copying to result} { + testdstring free + testdstring append xyz -1 + testdstring result +} xyz +test dstring-5.2 {copying to result} { + testdstring free + foreach l {a b c d e f g h i j k l m n o p} { + testdstring append $l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l\n -1 + } + set a [testdstring result] + testdstring append abc -1 + list $a [testdstring get] +} {{aaaaaaaaaaaaaaaaaaaaa +bbbbbbbbbbbbbbbbbbbbb +ccccccccccccccccccccc +ddddddddddddddddddddd +eeeeeeeeeeeeeeeeeeeee +fffffffffffffffffffff +ggggggggggggggggggggg +hhhhhhhhhhhhhhhhhhhhh +iiiiiiiiiiiiiiiiiiiii +jjjjjjjjjjjjjjjjjjjjj +kkkkkkkkkkkkkkkkkkkkk +lllllllllllllllllllll +mmmmmmmmmmmmmmmmmmmmm +nnnnnnnnnnnnnnnnnnnnn +ooooooooooooooooooooo +ppppppppppppppppppppp +} abc} + +testdstring free diff --git a/vendor/x11iraf/obm/Tcl/tests/env.test b/vendor/x11iraf/obm/Tcl/tests/env.test new file mode 100644 index 00000000..43e92490 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/tests/env.test @@ -0,0 +1,122 @@ +# Commands covered: none (tests environment variable implementation) +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1991-1993 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. +# +# $Header: /user6/ouster/tcl/tests/RCS/env.test,v 1.7 93/10/14 14:59:14 ouster Exp $ (Berkeley) + +if {[string compare test [info procs test]] == 1} then {source defs} + +# If there is no "printenv" program on this system, then it's just too +# much trouble to run this test (can't necessarily run csh to get the +# environment: on some systems it barfs if there isn't a minimum set +# predefined environment variables. Also, printenv returns a non-zero +# status on some systems, so read the environment using a procedure +# that catches errors. + +set printenv {} +if [info exists env(PATH)] { + set dirs [split $env(PATH) :] +} else { + set dirs {/bin /usr/bin /usr/ucb /usr/local /usr/public /usr/etc} +} +foreach i $dirs { + if [file executable $i/printenv] { + # The following hack is needed because of weirdness with + # environment variables in symbolic lines on Apollos (?!#?). + if ![catch {exec sh -c "cd $i; pwd"} x] { + set printenv $x/printenv + } else { + set printenv $i/printenv + } + break + } +} +if {$printenv == ""} { + puts stdout "Skipping env tests: need \"printenv\" to read environment." + return "" +} +proc getenv {} { + global printenv + catch {exec $printenv} out + if {$out == "child process exited abnormally"} { + set out {} + } + return $out +} + +# Save the current environment variables at the start of the test. + +foreach name [array names env] { + set env2($name) $env($name) + unset env($name) +} + +test env-1.1 {adding environment variables} { + getenv +} {} + +set env(NAME1) "test string" +test env-1.2 {adding environment variables} { + getenv +} {NAME1=test string} + +set env(NAME2) "more" +test env-1.3 {adding environment variables} { + getenv +} {NAME1=test string +NAME2=more} + +set env(XYZZY) "garbage" +test env-1.4 {adding environment variables} { + getenv +} {NAME1=test string +NAME2=more +XYZZY=garbage} + +set env(NAME2) "new value" +test env-2.1 {changing environment variables} { + getenv +} {NAME1=test string +NAME2=new value +XYZZY=garbage} + +unset env(NAME2) +test env-3.1 {unsetting environment variables} { + getenv +} {NAME1=test string +XYZZY=garbage} +unset env(NAME1) +test env-3.2 {unsetting environment variables} { + getenv +} {XYZZY=garbage} + +# Restore the environment variables at the end of the test. + +foreach name [array names env] { + unset env($name) +} +foreach name [array names env2] { + set env($name) $env2($name) +} diff --git a/vendor/x11iraf/obm/Tcl/tests/error.test b/vendor/x11iraf/obm/Tcl/tests/error.test new file mode 100644 index 00000000..e2410aab --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/tests/error.test @@ -0,0 +1,185 @@ +# Commands covered: error, catch +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1991-1993 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. +# +# $Header: /user6/ouster/tcl/tests/RCS/error.test,v 1.12 93/02/06 15:54:01 ouster Exp $ (Berkeley) + +if {[string compare test [info procs test]] == 1} then {source defs} + +proc foo {} { + global errorInfo + set a [catch {format [error glorp2]} b] + error {Human-generated} +} + +proc foo2 {} { + global errorInfo + set a [catch {format [error glorp2]} b] + error {Human-generated} $errorInfo +} + +# Catch errors occurring in commands and errors from "error" command + +test error-1.1 {simple errors from commands} { + catch {format [string compare]} b +} 1 + +test error-1.2 {simple errors from commands} { + catch {format [string compare]} b + set b +} {wrong # args: should be "string compare string1 string2"} + +test error-1.3 {simple errors from commands} { + catch {format [string compare]} b + set errorInfo +} {wrong # args: should be "string compare string1 string2" + while executing +"string compare" + invoked from within +"format [string compare]..."} + +test error-1.4 {simple errors from commands} { + catch {error glorp} b +} 1 + +test error-1.5 {simple errors from commands} { + catch {error glorp} b + set b +} glorp + +test error-1.6 {simple errors from commands} { + catch {catch a b c} b +} 1 + +test error-1.7 {simple errors from commands} { + catch {catch a b c} b + set b +} {wrong # args: should be "catch command ?varName?"} + +test error-2.1 {simple errors from commands} { + catch catch +} 1 + +# Check errors nested in procedures. Also check the optional argument +# to "error" to generate a new error trace. + +test error-2.1 {errors in nested procedures} { + catch foo b +} 1 + +test error-2.2 {errors in nested procedures} { + catch foo b + set b +} {Human-generated} + +test error-2.3 {errors in nested procedures} { + catch foo b + set errorInfo +} {Human-generated + while executing +"error {Human-generated}" + (procedure "foo" line 4) + invoked from within +"foo"} + +test error-2.4 {errors in nested procedures} { + catch foo2 b +} 1 + +test error-2.5 {errors in nested procedures} { + catch foo2 b + set b +} {Human-generated} + +test error-2.6 {errors in nested procedures} { + catch foo2 b + set errorInfo +} {glorp2 + while executing +"error glorp2" + invoked from within +"format [error glorp2]..." + (procedure "foo2" line 1) + invoked from within +"foo2"} + +# Error conditions related to "catch". + +test error-3.1 {errors in catch command} { + list [catch {catch} msg] $msg +} {1 {wrong # args: should be "catch command ?varName?"}} +test error-3.2 {errors in catch command} { + list [catch {catch a b c} msg] $msg +} {1 {wrong # args: should be "catch command ?varName?"}} +test error-3.3 {errors in catch command} { + catch {unset a} + set a(0) 22 + list [catch {catch {format 44} a} msg] $msg +} {1 {couldn't save command result in variable}} +catch {unset a} + +# More tests related to errorInfo and errorCode + +test error-4.1 {errorInfo and errorCode variables} { + list [catch {error msg1 msg2 msg3} msg] $msg $errorInfo $errorCode +} {1 msg1 msg2 msg3} +test error-4.2 {errorInfo and errorCode variables} { + list [catch {error msg1 {} msg3} msg] $msg $errorInfo $errorCode +} {1 msg1 {msg1 + while executing +"error msg1 {} msg3"} msg3} +test error-4.3 {errorInfo and errorCode variables} { + list [catch {error msg1 {}} msg] $msg $errorInfo $errorCode +} {1 msg1 {msg1 + while executing +"error msg1 {}"} NONE} +test error-4.4 {errorInfo and errorCode variables} { + set errorCode bogus + list [catch {error msg1} msg] $msg $errorInfo $errorCode +} {1 msg1 {msg1 + while executing +"error msg1"} NONE} +test error-4.5 {errorInfo and errorCode variables} { + set errorCode bogus + list [catch {error msg1 msg2 {}} msg] $msg $errorInfo $errorCode +} {1 msg1 msg2 {}} + +# Errors in error command itself + +test error-5.1 {errors in error command} { + list [catch {error} msg] $msg +} {1 {wrong # args: should be "error message ?errorInfo? ?errorCode?"}} +test error-5.2 {errors in error command} { + list [catch {error a b c d} msg] $msg +} {1 {wrong # args: should be "error message ?errorInfo? ?errorCode?"}} + +# Make sure that catch resets error information + +test error-6.1 {catch must reset error state} { + catch {error outer [catch {error inner inner.errorInfo inner.errorCode}]} + list $errorCode $errorInfo +} {NONE 1} + +return "" diff --git a/vendor/x11iraf/obm/Tcl/tests/eval.test b/vendor/x11iraf/obm/Tcl/tests/eval.test new file mode 100644 index 00000000..b75460ff --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/tests/eval.test @@ -0,0 +1,69 @@ +# Commands covered: eval +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1991-1993 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. +# +# $Header: /user6/ouster/tcl/tests/RCS/eval.test,v 1.5 93/02/06 15:54:14 ouster Exp $ (Berkeley) + +if {[string compare test [info procs test]] == 1} then {source defs} + +test eval-1.1 {single argument} { + eval {format 22} +} 22 +test eval-1.2 {multiple arguments} { + set a {$b} + set b xyzzy + eval format $a +} xyzzy +test eval-1.3 {single argument} { + eval concat a b c d e f g +} {a b c d e f g} + +test eval-2.1 {error: not enough arguments} {catch eval} 1 +test eval-2.2 {error: not enough arguments} { + catch eval msg + set msg +} {wrong # args: should be "eval arg ?arg ...?"} +test eval-2.3 {error in eval'ed command} { + catch {eval {error "test error"}} +} 1 +test eval-2.4 {error in eval'ed command} { + catch {eval {error "test error"}} msg + set msg +} {test error} +test eval-2.5 {error in eval'ed command: setting errorInfo} { + catch {eval { + set a 1 + error "test error" + }} msg + set errorInfo +} "test error + while executing +\"error \"test error\"\" + (\"eval\" body line 3) + invoked from within +\"eval { + set a 1 + error \"test error\" + }\"" diff --git a/vendor/x11iraf/obm/Tcl/tests/exec.test b/vendor/x11iraf/obm/Tcl/tests/exec.test new file mode 100644 index 00000000..3528b526 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/tests/exec.test @@ -0,0 +1,435 @@ +# Commands covered: exec +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1991-1993 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. +# +# $Header: /user6/ouster/tcl/tests/RCS/exec.test,v 1.30 93/09/16 16:57:43 ouster Exp $ (Berkeley) + +if {[string compare test [info procs test]] == 1} then {source defs} + +# Basic operations. + +test exec-1.1 {basic exec operation} { + exec echo a b c +} "a b c" +test exec-1.2 {pipelining} { + exec echo a b c d | cat | cat +} "a b c d" +test exec-1.3 {pipelining} { + set a [exec echo a b c d | cat | wc] + list [scan $a "%d %d %d" b c d] $b $c $d +} {3 1 4 8} + +# I/O redirection: input from Tcl command. + +test exec-2.1 {redirecting input from immediate source} { + exec cat << "Sample text" +} {Sample text} +test exec-2.2 {redirecting input from immediate source} { + exec << "Sample text" cat | cat +} {Sample text} +test exec-2.3 {redirecting input from immediate source} { + exec cat << "Sample text" | cat +} {Sample text} +test exec-2.4 {redirecting input from immediate source} { + exec cat | cat << "Sample text" +} {Sample text} +test exec-2.5 {redirecting input from immediate source} { + exec cat "<<Joined to arrows" +} {Joined to arrows} + +# I/O redirection: output to file. + +catch {exec rm -f gorp.file} +test exec-3.1 {redirecting output to file} { + exec echo "Some simple words" > gorp.file + exec cat gorp.file +} "Some simple words" +test exec-3.2 {redirecting output to file} { + exec echo "More simple words" | >gorp.file cat | cat + exec cat gorp.file +} "More simple words" +test exec-3.3 {redirecting output to file} { + exec > gorp.file echo "Different simple words" | cat | cat + exec cat gorp.file +} "Different simple words" +test exec-3.4 {redirecting output to file} { + exec echo "Some simple words" >gorp.file + exec cat gorp.file +} "Some simple words" +test exec-3.5 {redirecting output to file} { + exec echo "First line" >gorp.file + exec echo "Second line" >> gorp.file + exec cat gorp.file +} "First line\nSecond line" +test exec-3.6 {redirecting output to file} { + exec echo "First line" >gorp.file + exec echo "Second line" >>gorp.file + exec cat gorp.file +} "First line\nSecond line" +test exec-3.7 {redirecting output to file} { + set f [open gorp.file w] + puts $f "Line 1" + flush $f + exec echo "More text" >@ $f + exec echo >@$f "Even more" + puts $f "Line 3" + close $f + exec cat gorp.file +} "Line 1\nMore text\nEven more\nLine 3" + +# I/O redirection: output and stderr to file. + +catch {exec rm -f gorp.file} +test exec-4.1 {redirecting output and stderr to file} { + exec echo "test output" >& gorp.file + exec cat gorp.file +} "test output" +test exec-4.2 {redirecting output and stderr to file} { + list [exec sh -c "echo foo bar 1>&2" >&gorp.file] \ + [exec cat gorp.file] +} {{} {foo bar}} +test exec-4.3 {redirecting output and stderr to file} { + exec echo "first line" > gorp.file + list [exec sh -c "echo foo bar 1>&2" >>&gorp.file] \ + [exec cat gorp.file] +} "{} {first line\nfoo bar}" +test exec-4.4 {redirecting output and stderr to file} { + set f [open gorp.file w] + puts $f "Line 1" + flush $f + exec echo "More text" >&@ $f + exec echo >&@$f "Even more" + puts $f "Line 3" + close $f + exec cat gorp.file +} "Line 1\nMore text\nEven more\nLine 3" +test exec-4.5 {redirecting output and stderr to file} { + set f [open gorp.file w] + puts $f "Line 1" + flush $f + exec >&@ $f sh -c "echo foo bar 1>&2" + exec >&@$f sh -c "echo xyzzy 1>&2" + puts $f "Line 3" + close $f + exec cat gorp.file +} "Line 1\nfoo bar\nxyzzy\nLine 3" + +# I/O redirection: input from file. + +exec echo "Just a few thoughts" > gorp.file +test exec-5.1 {redirecting input from file} { + exec cat < gorp.file +} {Just a few thoughts} +test exec-5.2 {redirecting input from file} { + exec cat | cat < gorp.file +} {Just a few thoughts} +test exec-5.3 {redirecting input from file} { + exec cat < gorp.file | cat +} {Just a few thoughts} +test exec-5.4 {redirecting input from file} { + exec < gorp.file cat | cat +} {Just a few thoughts} +test exec-5.5 {redirecting input from file} { + exec cat <gorp.file +} {Just a few thoughts} +test exec-5.6 {redirecting input from file} { + set f [open gorp.file r] + set result [exec cat <@ $f] + close $f + set result +} {Just a few thoughts} +test exec-5.7 {redirecting input from file} { + set f [open gorp.file r] + set result [exec <@$f cat] + close $f + set result +} {Just a few thoughts} + +# I/O redirection: standard error through a pipeline. + +test exec-6.1 {redirecting stderr through a pipeline} { + exec sh -c "echo foo bar" |& cat +} "foo bar" +test exec-6.2 {redirecting stderr through a pipeline} { + exec sh -c "echo foo bar 1>&2" |& cat +} "foo bar" +test exec-6.3 {redirecting stderr through a pipeline} { + exec sh -c "echo foo bar 1>&2" |& sh -c "echo second msg 1>& 2; cat" |& cat +} "second msg\nfoo bar" + +# I/O redirection: combinations. + +catch {exec rm -f gorp.file2} +test exec-7.1 {multiple I/O redirections} { + exec << "command input" > gorp.file2 cat < gorp.file + exec cat gorp.file2 +} {Just a few thoughts} +test exec-7.2 {multiple I/O redirections} { + exec < gorp.file << "command input" cat +} {command input} + +# Long input to command and output from command. + +set a "0123456789 xxxxxxxxx abcdefghi ABCDEFGHIJK\n" +set a [concat $a $a $a $a] +set a [concat $a $a $a $a] +set a [concat $a $a $a $a] +set a [concat $a $a $a $a] +test exec-8.1 {long input and output} { + exec cat << $a +} $a + +# Commands that return errors. + +test exec-9.1 {commands returning errors} { + set x [catch {exec gorp456} msg] + list $x $msg [lindex $errorCode 0] [lrange $errorCode 2 end] +} {1 {couldn't find "gorp456" to execute} CHILDSTATUS 1} +test exec-9.2 {commands returning errors} { + set x [catch {exec foo123 | gorp456} msg] + set x1 {couldn't find "foo123" to execute +couldn't find "gorp456" to execute} + set x2 {couldn't find "gorp456" to execute +couldn't find "foo123" to execute} + set y [expr {($msg == $x1) || ($msg == $x2)}] + list $x $y [lindex $errorCode 0] [lrange $errorCode 2 end] +} {1 1 CHILDSTATUS 1} +test exec-9.3 {commands returning errors} { + list [catch {exec sleep 1 | sh -c "exit 43" | sleep 1} msg] $msg +} {1 {child process exited abnormally}} +test exec-9.4 {commands returning errors} { + list [catch {exec gorp456 | echo a b c} msg] $msg +} {1 {a b c +couldn't find "gorp456" to execute}} +test exec-9.5 {commands returning errors} { + list [catch {exec sh -c "echo error msg 1>&2"} msg] $msg +} {1 {error msg}} +test exec-9.6 {commands returning errors} { + list [catch {exec sh -c "echo error msg 1>&2" | sh -c "echo error msg 1>&2"} msg] $msg +} {1 {error msg +error msg}} + +# Errors in executing the Tcl command, as opposed to errors in the +# processes that are invoked. + +test exec-10.1 {errors in exec invocation} { + list [catch {exec} msg] $msg +} {1 {wrong # args: should be "exec ?switches? arg ?arg ...?"}} +test exec-10.2 {errors in exec invocation} { + list [catch {exec | cat} msg] $msg +} {1 {illegal use of | or |& in command}} +test exec-10.3 {errors in exec invocation} { + list [catch {exec cat |} msg] $msg +} {1 {illegal use of | or |& in command}} +test exec-10.4 {errors in exec invocation} { + list [catch {exec cat | | cat} msg] $msg +} {1 {illegal use of | or |& in command}} +test exec-10.5 {errors in exec invocation} { + list [catch {exec cat | |& cat} msg] $msg +} {1 {illegal use of | or |& in command}} +test exec-10.6 {errors in exec invocation} { + list [catch {exec cat |&} msg] $msg +} {1 {illegal use of | or |& in command}} +test exec-10.7 {errors in exec invocation} { + list [catch {exec cat <} msg] $msg +} {1 {can't specify "<" as last word in command}} +test exec-10.8 {errors in exec invocation} { + list [catch {exec cat >} msg] $msg +} {1 {can't specify ">" as last word in command}} +test exec-10.9 {errors in exec invocation} { + list [catch {exec cat <<} msg] $msg +} {1 {can't specify "<<" as last word in command}} +test exec-10.10 {errors in exec invocation} { + list [catch {exec cat >>} msg] $msg +} {1 {can't specify ">>" as last word in command}} +test exec-10.11 {errors in exec invocation} { + list [catch {exec cat >&} msg] $msg +} {1 {can't specify ">&" as last word in command}} +test exec-10.12 {errors in exec invocation} { + list [catch {exec cat >>&} msg] $msg +} {1 {can't specify ">>&" as last word in command}} +test exec-10.13 {errors in exec invocation} { + list [catch {exec cat >@} msg] $msg +} {1 {can't specify ">@" as last word in command}} +test exec-10.14 {errors in exec invocation} { + list [catch {exec cat <@} msg] $msg +} {1 {can't specify "<@" as last word in command}} +test exec-10.15 {errors in exec invocation} { + list [catch {exec cat < a/b/c} msg] [string tolower $msg] +} {1 {couldn't read file "a/b/c": no such file or directory}} +test exec-10.16 {errors in exec invocation} { + list [catch {exec cat << foo > a/b/c} msg] [string tolower $msg] +} {1 {couldn't write file "a/b/c": no such file or directory}} +test exec-10.17 {errors in exec invocation} { + list [catch {exec cat << foo > a/b/c} msg] [string tolower $msg] +} {1 {couldn't write file "a/b/c": no such file or directory}} +set f [open gorp.file w] +test exec-10.18 {errors in exec invocation} { + list [catch {exec cat <@ $f} msg] $msg +} "1 {\"$f\" wasn't opened for reading}" +close $f +set f [open gorp.file r] +test exec-10.19 {errors in exec invocation} { + list [catch {exec cat >@ $f} msg] $msg +} "1 {\"$f\" wasn't opened for writing}" +close $f + +# Commands in background. + +test exec-11.1 {commands in background} { + set x [lindex [time {exec sleep 2 &}] 0] + expr $x<1000000 +} 1 +test exec-11.2 {commands in background} { + list [catch {exec echo a &b} msg] $msg +} {0 {a &b}} +test exec-11.3 {commands in background} { + llength [exec sleep 1 &] +} 1 +test exec-11.4 {commands in background} { + llength [exec sleep 1 | sleep 1 | sleep 1 &] +} 3 + +# Make sure that background commands are properly reaped when +# they eventually die. + +exec sleep 3 +if $atBerkeley { + test exec-12.1 {reaping background processes} { + for {set i 0} {$i < 20} {incr i} { + exec echo foo > /dev/null & + } + exec sleep 1 + catch {exec ps | fgrep "echo foo" | fgrep -v fgrep | wc} msg + lindex $msg 0 + } 0 + test exec-12.2 {reaping background processes} { + exec sleep 2 | sleep 2 | sleep 2 & + catch {exec ps | fgrep "sleep 2" | fgrep -v fgrep | wc} msg + set x [lindex $msg 0] + exec sleep 3 + catch {exec ps | fgrep "sleep 2" | fgrep -v fgrep | wc} msg + list $x [lindex $msg 0] + } {3 0} + test exec-12.3 {reaping background processes} { + exec sleep 1000 & + exec sleep 1000 & + set x [exec ps | fgrep "sleep 1000" | fgrep -v fgrep] + set pids {} + foreach i [split $x \n] { + lappend pids [lindex $i 0] + } + foreach i $pids { + catch {exec kill -STOP $i} + } + catch {exec ps | fgrep "sleep 1000" | fgrep -v fgrep | wc} msg + set x [lindex $msg 0] + + foreach i $pids { + catch {exec kill -KILL $i} + } + catch {exec ps | fgrep "sleep 1000" | fgrep -v fgrep | wc} msg + list $x [lindex $msg 0] + } {2 0} +} + +# Make sure "errorCode" is set correctly. + +test exec-13.1 {setting errorCode variable} { + list [catch {exec cat < a/b/c} msg] [string tolower $errorCode] +} {1 {posix enoent {no such file or directory}}} +test exec-13.2 {setting errorCode variable} { + list [catch {exec cat > a/b/c} msg] [string tolower $errorCode] +} {1 {posix enoent {no such file or directory}}} +test exec-13.3 {setting errorCode variable} { + set x [catch {exec _weirdo_command_} msg] + list $x $msg [lindex $errorCode 0] [lrange $errorCode 2 end] +} {1 {couldn't find "_weirdo_command_" to execute} CHILDSTATUS 1} + +# Switches before the first argument + +test exec-14.1 {-keepnewline switch} { + exec -keepnewline echo foo +} "foo\n" +test exec-14.2 {-keepnewline switch} { + list [catch {exec -keepnewline} msg] $msg +} {1 {wrong # args: should be "exec ?switches? arg ?arg ...?"}} +test exec-14.3 {unknown switch} { + list [catch {exec -gorp} msg] $msg +} {1 {bad switch "-gorp": must be -keepnewline or --}} +test exec-14.4 {-- switch} { + list [catch {exec -- -gorp} msg] $msg +} {1 {couldn't find "-gorp" to execute}} + +# Redirecting standard error separately from standard output + +test exec-15.1 {standard error redirection} { + exec echo "First line" > gorp.file + list [exec sh -c "echo foo bar 1>&2" 2> gorp.file] \ + [exec cat gorp.file] +} {{} {foo bar}} +test exec-15.2 {standard error redirection} { + list [exec sh -c "echo foo bar 1>&2" | echo biz baz >gorp.file \ + 2> gorp.file2] [exec cat gorp.file] \ + [exec cat gorp.file2] +} {{} {biz baz} {foo bar}} +test exec-15.3 {standard error redirection} { + list [exec sh -c "echo foo bar 1>&2" | echo biz baz 2>gorp.file \ + > gorp.file2] [exec cat gorp.file] \ + [exec cat gorp.file2] +} {{} {foo bar} {biz baz}} +test exec-15.4 {standard error redirection} { + set f [open gorp.file w] + puts $f "Line 1" + flush $f + exec sh -c "echo foo bar 1>&2" 2>@ $f + puts $f "Line 3" + close $f + exec cat gorp.file +} {Line 1 +foo bar +Line 3} +test exec-15.5 {standard error redirection} { + exec echo "First line" > gorp.file + exec sh -c "echo foo bar 1>&2" 2>> gorp.file + exec cat gorp.file +} {First line +foo bar} +test exec-15.6 {standard error redirection} { + exec sh -c "echo foo bar 1>&2" > gorp.file2 2> gorp.file \ + >& gorp.file 2> gorp.file2 | echo biz baz + list [exec cat gorp.file] [exec cat gorp.file2] +} {{biz baz} {foo bar}} + +if $atBerkeley { + test exec-16.1 {restore signal settings before exec} { + set f [open {|cat exec.test} r] + list [catch {close $f} msg] [string tolower $msg] + } {1 {child killed: write on pipe with no readers}} +} + +catch {exec rm -f gorp.file} +catch {exec rm -f gorp.file2} +return {} diff --git a/vendor/x11iraf/obm/Tcl/tests/expr.test b/vendor/x11iraf/obm/Tcl/tests/expr.test new file mode 100644 index 00000000..199134fd --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/tests/expr.test @@ -0,0 +1,822 @@ +# Commands covered: expr +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1991-1993 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. +# +# $Header: /user6/ouster/tcl/tests/RCS/expr.test,v 1.30 93/09/08 16:46:45 ouster Exp $ (Berkeley) + +if {[string compare test [info procs test]] == 1} then {source defs} + +if {([catch {expr T1()} msg] == 1) && ($msg == {unknown math function "T1"})} { + set gotT1 0 + puts "This application hasn't been compiled with the \"T1\" and" + puts "\"T2\" math functions, so I'll skip some of the expr tests." +} else { + set gotT1 1 +} + +# First, test all of the integer operators individually. + +test expr-1.1 {integer operators} {expr -4} -4 +test expr-1.2 {integer operators} {expr -(1+4)} -5 +test expr-1.3 {integer operators} {expr ~3} -4 +test expr-1.4 {integer operators} {expr !2} 0 +test expr-1.5 {integer operators} {expr !0} 1 +test expr-1.6 {integer operators} {expr 4*6} 24 +test expr-1.7 {integer operators} {expr 36/12} 3 +test expr-1.8 {integer operators} {expr 27/4} 6 +test expr-1.9 {integer operators} {expr 27%4} 3 +test expr-1.10 {integer operators} {expr 2+2} 4 +test expr-1.11 {integer operators} {expr 2-6} -4 +test expr-1.12 {integer operators} {expr 1<<3} 8 +test expr-1.13 {integer operators} {expr 0xff>>2} 63 +test expr-1.14 {integer operators} {expr -1>>2} -1 +test expr-1.15 {integer operators} {expr 3>2} 1 +test expr-1.16 {integer operators} {expr 2>2} 0 +test expr-1.17 {integer operators} {expr 1>2} 0 +test expr-1.18 {integer operators} {expr 3<2} 0 +test expr-1.19 {integer operators} {expr 2<2} 0 +test expr-1.20 {integer operators} {expr 1<2} 1 +test expr-1.21 {integer operators} {expr 3>=2} 1 +test expr-1.22 {integer operators} {expr 2>=2} 1 +test expr-1.23 {integer operators} {expr 1>=2} 0 +test expr-1.24 {integer operators} {expr 3<=2} 0 +test expr-1.25 {integer operators} {expr 2<=2} 1 +test expr-1.26 {integer operators} {expr 1<=2} 1 +test expr-1.27 {integer operators} {expr 3==2} 0 +test expr-1.28 {integer operators} {expr 2==2} 1 +test expr-1.29 {integer operators} {expr 3!=2} 1 +test expr-1.30 {integer operators} {expr 2!=2} 0 +test expr-1.31 {integer operators} {expr 7&0x13} 3 +test expr-1.32 {integer operators} {expr 7^0x13} 20 +test expr-1.33 {integer operators} {expr 7|0x13} 23 +test expr-1.34 {integer operators} {expr 0&&1} 0 +test expr-1.35 {integer operators} {expr 0&&0} 0 +test expr-1.36 {integer operators} {expr 1&&3} 1 +test expr-1.37 {integer operators} {expr 0||1} 1 +test expr-1.38 {integer operators} {expr 3||0} 1 +test expr-1.39 {integer operators} {expr 0||0} 0 +test expr-1.40 {integer operators} {expr 3>2?44:66} 44 +test expr-1.41 {integer operators} {expr 2>3?44:66} 66 +test expr-1.42 {integer operators} {expr 36/5} 7 +test expr-1.43 {integer operators} {expr 36%5} 1 +test expr-1.44 {integer operators} {expr -36/5} -8 +test expr-1.45 {integer operators} {expr -36%5} 4 +test expr-1.46 {integer operators} {expr 36/-5} -8 +test expr-1.47 {integer operators} {expr 36%-5} -4 +test expr-1.48 {integer operators} {expr -36/-5} 7 +test expr-1.49 {integer operators} {expr -36%-5} -1 + +# Check the floating-point operators individually, along with +# automatic conversion to integers where needed. + +test expr-2.1 {floating-point operators} {expr -4.2} -4.2 +test expr-2.2 {floating-point operators} {expr -(1.1+4.2)} -5.3 +test expr-2.3 {floating-point operators} {expr !2.1} 0 +test expr-2.4 {floating-point operators} {expr !0.0} 1 +test expr-2.5 {floating-point operators} {expr 4.2*6.3} 26.46 +test expr-2.6 {floating-point operators} {expr 36.0/12.0} 3.0 +test expr-2.7 {floating-point operators} {expr 27/4.0} 6.75 +test expr-2.8 {floating-point operators} {expr 2.3+2.1} 4.4 +test expr-2.9 {floating-point operators} {expr 2.3-6.5} -4.2 +test expr-2.10 {floating-point operators} {expr 3.1>2.1} 1 +test expr-2.11 {floating-point operators} {expr {2.1 > 2.1}} 0 +test expr-2.12 {floating-point operators} {expr 1.23>2.34e+1} 0 +test expr-2.13 {floating-point operators} {expr 3.45<2.34} 0 +test expr-2.14 {floating-point operators} {expr 0.002e3<--200e-2} 0 +test expr-2.15 {floating-point operators} {expr 1.1<2.1} 1 +test expr-2.16 {floating-point operators} {expr 3.1>=2.2} 1 +test expr-2.17 {floating-point operators} {expr 2.345>=2.345} 1 +test expr-2.18 {floating-point operators} {expr 1.1>=2.2} 0 +test expr-2.19 {floating-point operators} {expr 3.0<=2.0} 0 +test expr-2.20 {floating-point operators} {expr 2.2<=2.2} 1 +test expr-2.21 {floating-point operators} {expr 2.2<=2.2001} 1 +test expr-2.22 {floating-point operators} {expr 3.2==2.2} 0 +test expr-2.23 {floating-point operators} {expr 2.2==2.2} 1 +test expr-2.24 {floating-point operators} {expr 3.2!=2.2} 1 +test expr-2.25 {floating-point operators} {expr 2.2!=2.2} 0 +test expr-2.26 {floating-point operators} {expr 0.0&&0.0} 0 +test expr-2.27 {floating-point operators} {expr 0.0&&1.3} 0 +test expr-2.28 {floating-point operators} {expr 1.3&&0.0} 0 +test expr-2.29 {floating-point operators} {expr 1.3&&3.3} 1 +test expr-2.30 {floating-point operators} {expr 0.0||0.0} 0 +test expr-2.31 {floating-point operators} {expr 0.0||1.3} 1 +test expr-2.32 {floating-point operators} {expr 1.3||0.0} 1 +test expr-2.33 {floating-point operators} {expr 3.3||0.0} 1 +test expr-2.34 {floating-point operators} {expr 3.3>2.3?44.3:66.3} 44.3 +test expr-2.35 {floating-point operators} {expr 2.3>3.3?44.3:66.3} 66.3 +test expr-2.36 {floating-point operators} { + list [catch {expr 028.1 + 09.2} msg] $msg +} {0 37.3} + +# Operators that aren't legal on floating-point numbers + +test expr-3.1 {illegal floating-point operations} { + list [catch {expr ~4.0} msg] $msg +} {1 {can't use floating-point value as operand of "~"}} +test expr-3.2 {illegal floating-point operations} { + list [catch {expr 27%4.0} msg] $msg +} {1 {can't use floating-point value as operand of "%"}} +test expr-3.3 {illegal floating-point operations} { + list [catch {expr 27.0%4} msg] $msg +} {1 {can't use floating-point value as operand of "%"}} +test expr-3.4 {illegal floating-point operations} { + list [catch {expr 1.0<<3} msg] $msg +} {1 {can't use floating-point value as operand of "<<"}} +test expr-3.5 {illegal floating-point operations} { + list [catch {expr 3<<1.0} msg] $msg +} {1 {can't use floating-point value as operand of "<<"}} +test expr-3.6 {illegal floating-point operations} { + list [catch {expr 24.0>>3} msg] $msg +} {1 {can't use floating-point value as operand of ">>"}} +test expr-3.7 {illegal floating-point operations} { + list [catch {expr 24>>3.0} msg] $msg +} {1 {can't use floating-point value as operand of ">>"}} +test expr-3.8 {illegal floating-point operations} { + list [catch {expr 24&3.0} msg] $msg +} {1 {can't use floating-point value as operand of "&"}} +test expr-3.9 {illegal floating-point operations} { + list [catch {expr 24.0|3} msg] $msg +} {1 {can't use floating-point value as operand of "|"}} +test expr-3.10 {illegal floating-point operations} { + list [catch {expr 24.0^3} msg] $msg +} {1 {can't use floating-point value as operand of "^"}} + +# Check the string operators individually. + +test expr-4.1 {string operators} {expr {"abc" > "def"}} 0 +test expr-4.2 {string operators} {expr {"def" > "def"}} 0 +test expr-4.3 {string operators} {expr {"g" > "def"}} 1 +test expr-4.4 {string operators} {expr {"abc" < "abd"}} 1 +test expr-4.5 {string operators} {expr {"abd" < "abd"}} 0 +test expr-4.6 {string operators} {expr {"abe" < "abd"}} 0 +test expr-4.7 {string operators} {expr {"abc" >= "def"}} 0 +test expr-4.8 {string operators} {expr {"def" >= "def"}} 1 +test expr-4.9 {string operators} {expr {"g" >= "def"}} 1 +test expr-4.10 {string operators} {expr {"abc" <= "abd"}} 1 +test expr-4.11 {string operators} {expr {"abd" <= "abd"}} 1 +test expr-4.12 {string operators} {expr {"abe" <= "abd"}} 0 +test expr-4.13 {string operators} {expr {"abc" == "abd"}} 0 +test expr-4.14 {string operators} {expr {"abd" == "abd"}} 1 +test expr-4.15 {string operators} {expr {"abc" != "abd"}} 1 +test expr-4.16 {string operators} {expr {"abd" != "abd"}} 0 +test expr-4.17 {string operators} {expr {"0y" < "0x12"}} 1 +test expr-4.18 {string operators} {expr {"." < " "}} 0 +test expr-4.19 {string operators} {expr {"0" == "+"}} 0 +test expr-4.20 {string operators} {expr {"0" == "-"}} 0 +test expr-4.21 {string operators} {expr {1?"foo":"bar"}} foo +test expr-4.22 {string operators} {expr {0?"foo":"bar"}} bar + +# Operators that aren't legal on string operands. + +test expr-5.1 {illegal string operations} { + list [catch {expr {-"a"}} msg] $msg +} {1 {can't use non-numeric string as operand of "-"}} +test expr-5.2 {illegal string operations} { + list [catch {expr {~"a"}} msg] $msg +} {1 {can't use non-numeric string as operand of "~"}} +test expr-5.3 {illegal string operations} { + list [catch {expr {!"a"}} msg] $msg +} {1 {can't use non-numeric string as operand of "!"}} +test expr-5.4 {illegal string operations} { + list [catch {expr {"a"*"b"}} msg] $msg +} {1 {can't use non-numeric string as operand of "*"}} +test expr-5.5 {illegal string operations} { + list [catch {expr {"a"/"b"}} msg] $msg +} {1 {can't use non-numeric string as operand of "/"}} +test expr-5.6 {illegal string operations} { + list [catch {expr {"a"%"b"}} msg] $msg +} {1 {can't use non-numeric string as operand of "%"}} +test expr-5.7 {illegal string operations} { + list [catch {expr {"a"+"b"}} msg] $msg +} {1 {can't use non-numeric string as operand of "+"}} +test expr-5.8 {illegal string operations} { + list [catch {expr {"a"-"b"}} msg] $msg +} {1 {can't use non-numeric string as operand of "-"}} +test expr-5.9 {illegal string operations} { + list [catch {expr {"a"<<"b"}} msg] $msg +} {1 {can't use non-numeric string as operand of "<<"}} +test expr-5.10 {illegal string operations} { + list [catch {expr {"a">>"b"}} msg] $msg +} {1 {can't use non-numeric string as operand of ">>"}} +test expr-5.11 {illegal string operations} { + list [catch {expr {"a"&"b"}} msg] $msg +} {1 {can't use non-numeric string as operand of "&"}} +test expr-5.12 {illegal string operations} { + list [catch {expr {"a"^"b"}} msg] $msg +} {1 {can't use non-numeric string as operand of "^"}} +test expr-5.13 {illegal string operations} { + list [catch {expr {"a"|"b"}} msg] $msg +} {1 {can't use non-numeric string as operand of "|"}} +test expr-5.14 {illegal string operations} { + list [catch {expr {"a"&&"b"}} msg] $msg +} {1 {can't use non-numeric string as operand of "&&"}} +test expr-5.15 {illegal string operations} { + list [catch {expr {"a"||"b"}} msg] $msg +} {1 {can't use non-numeric string as operand of "||"}} +test expr-5.16 {illegal string operations} { + list [catch {expr {"a"?4:2}} msg] $msg +} {1 {can't use non-numeric string as operand of "?"}} + +# Check precedence pairwise. + +test expr-6.1 {precedence checks} {expr -~3} 4 +test expr-6.2 {precedence checks} {expr -!3} 0 +test expr-6.3 {precedence checks} {expr -~0} 1 + +test expr-7.1 {precedence checks} {expr 2*4/6} 1 +test expr-7.2 {precedence checks} {expr 24/6*3} 12 +test expr-7.3 {precedence checks} {expr 24/6/2} 2 + +test expr-8.1 {precedence checks} {expr -2+4} 2 +test expr-8.2 {precedence checks} {expr -2-4} -6 + +test expr-9.1 {precedence checks} {expr 2*3+4} 10 +test expr-9.2 {precedence checks} {expr 8/2+4} 8 +test expr-9.3 {precedence checks} {expr 8%3+4} 6 +test expr-9.4 {precedence checks} {expr 2*3-1} 5 +test expr-9.5 {precedence checks} {expr 8/2-1} 3 +test expr-9.6 {precedence checks} {expr 8%3-1} 1 + +test expr-10.1 {precedence checks} {expr 6-3-2} 1 + +test expr-11.1 {precedence checks} {expr 7+1>>2} 2 +test expr-11.2 {precedence checks} {expr 7+1<<2} 32 +test expr-11.3 {precedence checks} {expr 7>>3-2} 3 +test expr-11.4 {precedence checks} {expr 7<<3-2} 14 + +test expr-12.1 {precedence checks} {expr 6>>1>4} 0 +test expr-12.2 {precedence checks} {expr 6>>1<2} 0 +test expr-12.3 {precedence checks} {expr 6>>1>=3} 1 +test expr-12.4 {precedence checks} {expr 6>>1<=2} 0 +test expr-12.5 {precedence checks} {expr 6<<1>5} 1 +test expr-12.6 {precedence checks} {expr 6<<1<5} 0 +test expr-12.7 {precedence checks} {expr 5<=6<<1} 1 +test expr-12.8 {precedence checks} {expr 5>=6<<1} 0 + +test expr-13.1 {precedence checks} {expr 2<3<4} 1 +test expr-13.2 {precedence checks} {expr 0<4>2} 0 +test expr-13.3 {precedence checks} {expr 4>2<1} 0 +test expr-13.4 {precedence checks} {expr 4>3>2} 0 +test expr-13.5 {precedence checks} {expr 4>3>=2} 0 +test expr-13.6 {precedence checks} {expr 4>=3>2} 0 +test expr-13.7 {precedence checks} {expr 4>=3>=2} 0 +test expr-13.8 {precedence checks} {expr 0<=4>=2} 0 +test expr-13.9 {precedence checks} {expr 4>=2<=0} 0 +test expr-10.10 {precedence checks} {expr 2<=3<=4} 1 + +test expr-14.1 {precedence checks} {expr 1==4>3} 1 +test expr-14.2 {precedence checks} {expr 0!=4>3} 1 +test expr-14.3 {precedence checks} {expr 1==3<4} 1 +test expr-14.4 {precedence checks} {expr 0!=3<4} 1 +test expr-14.5 {precedence checks} {expr 1==4>=3} 1 +test expr-14.6 {precedence checks} {expr 0!=4>=3} 1 +test expr-14.7 {precedence checks} {expr 1==3<=4} 1 +test expr-14.8 {precedence checks} {expr 0!=3<=4} 1 + +test expr-15.1 {precedence checks} {expr 1==3==3} 0 +test expr-15.2 {precedence checks} {expr 3==3!=2} 1 +test expr-15.3 {precedence checks} {expr 2!=3==3} 0 +test expr-15.4 {precedence checks} {expr 2!=1!=1} 0 + +test expr-16.1 {precedence checks} {expr 2&3==2} 0 +test expr-16.2 {precedence checks} {expr 1&3!=3} 0 + +test expr-17.1 {precedence checks} {expr 7&3^0x10} 19 +test expr-17.2 {precedence checks} {expr 7^0x10&3} 7 + +test expr-18.1 {precedence checks} {expr 7^0x10|3} 23 +test expr-18.2 {precedence checks} {expr 7|0x10^3} 23 + +test expr-19.1 {precedence checks} {expr 7|3&&1} 1 +test expr-19.2 {precedence checks} {expr 1&&3|7} 1 +test expr-19.3 {precedence checks} {expr 0&&1||1} 1 +test expr-19.4 {precedence checks} {expr 1||1&&0} 1 + +test expr-20.1 {precedence checks} {expr 1||0?3:4} 3 +test expr-20.2 {precedence checks} {expr 1?0:4||1} 0 + +# Parentheses. + +test expr-21.1 {parenthesization} {expr (2+4)*6} 36 +test expr-21.2 {parenthesization} {expr (1?0:4)||1} 1 + +# Embedded commands and variable names. + +set a 16 +test expr-22.1 {embedded variables} {expr {2*$a}} 32 +test expr-22.2 {embedded variables} { + set x -5 + set y 10 + expr {$x + $y} +} {5} +test expr-22.3 {embedded variables} { + set x " -5" + set y " +10" + expr {$x + $y} +} {5} +test expr-22.4 {embedded commands and variables} {expr {[set a] - 14}} 2 +test expr-22.5 {embedded commands and variables} { + list [catch {expr {12 - [bad_command_name]}} msg] $msg +} {1 {invalid command name: "bad_command_name"}} + +# Double-quotes and things inside them. + +test expr-23.1 {double-quotes} {expr {"abc"}} abc +test expr-23.2 {double-quotes} { + set a 189 + expr {"$a.bc"} +} 189.bc +test expr-23.3 {double-quotes} { + set b2 xyx + expr {"$b2$b2$b2.[set b2].[set b2]"} +} xyxxyxxyx.xyx.xyx +test expr-23.4 {double-quotes} {expr {"11\}\}22"}} 11}}22 +test expr-23.5 {double-quotes} {expr {"\*bc"}} {*bc} +test expr-23.6 {double-quotes} { + catch {unset bogus__} + list [catch {expr {"$bogus__"}} msg] $msg +} {1 {can't read "bogus__": no such variable}} +test expr-23.7 {double-quotes} { + list [catch {expr {"a[error Testing]bc"}} msg] $msg +} {1 Testing} + +# Numbers in various bases. + +test expr-24.1 {numbers in different bases} {expr 0x20} 32 +test expr-24.2 {numbers in different bases} {expr 015} 13 + +# Conversions between various data types. + +test expr-25.1 {type conversions} {expr 2+2.5} 4.5 +test expr-25.2 {type conversions} {expr 2.5+2} 4.5 +test expr-25.3 {type conversions} {expr 2-2.5} -0.5 +test expr-25.4 {type conversions} {expr 2/2.5} 0.8 +test expr-25.5 {type conversions} {expr 2>2.5} 0 +test expr-25.6 {type conversions} {expr 2.5>2} 1 +test expr-25.7 {type conversions} {expr 2<2.5} 1 +test expr-25.8 {type conversions} {expr 2>=2.5} 0 +test expr-25.9 {type conversions} {expr 2<=2.5} 1 +test expr-25.10 {type conversions} {expr 2==2.5} 0 +test expr-25.11 {type conversions} {expr 2!=2.5} 1 +test expr-25.12 {type conversions} {expr 2>"ab"} 0 +test expr-25.13 {type conversions} {expr {2>" "}} 1 +test expr-25.14 {type conversions} {expr {"24.1a" > 24.1}} 1 +test expr-25.15 {type conversions} {expr {24.1 > "24.1a"}} 0 +test expr-25.16 {type conversions} {expr 2+2.5} 4.5 +test expr-25.17 {type conversions} {expr 2+2.5} 4.5 +test expr-25.18 {type conversions} {expr 2.0e2} 200.0 +test expr-25.19 {type conversions} {expr 2.0e15} 2e+15 +test expr-25.20 {type conversions} {expr 10.0} 10.0 + +# Various error conditions. + +test expr-26.1 {error conditions} { + list [catch {expr 2+"a"} msg] $msg +} {1 {can't use non-numeric string as operand of "+"}} +test expr-26.2 {error conditions} { + list [catch {expr 2+4*} msg] $msg +} {1 {syntax error in expression "2+4*"}} +test expr-26.3 {error conditions} { + list [catch {expr 2+4*(} msg] $msg +} {1 {syntax error in expression "2+4*("}} +catch {unset _non_existent_} +test expr-26.4 {error conditions} { + list [catch {expr 2+$_non_existent_} msg] $msg +} {1 {can't read "_non_existent_": no such variable}} +set a xx +test expr-26.5 {error conditions} { + list [catch {expr {2+$a}} msg] $msg +} {1 {can't use non-numeric string as operand of "+"}} +test expr-26.6 {error conditions} { + list [catch {expr {2+[set a]}} msg] $msg +} {1 {can't use non-numeric string as operand of "+"}} +test expr-26.7 {error conditions} { + list [catch {expr {2+(4}} msg] $msg +} {1 {unmatched parentheses in expression "2+(4"}} +test expr-26.8 {error conditions} { + list [catch {expr 2/0} msg] $msg $errorCode +} {1 {divide by zero} {ARITH DIVZERO {divide by zero}}} +test expr-26.9 {error conditions} { + list [catch {expr 2%0} msg] $msg $errorCode +} {1 {divide by zero} {ARITH DIVZERO {divide by zero}}} +test expr-26.10 {error conditions} { + list [catch {expr 2.0/0.0} msg] $msg $errorCode +} {1 {divide by zero} {ARITH DIVZERO {divide by zero}}} +test expr-26.11 {error conditions} { + list [catch {expr 2#} msg] $msg +} {1 {syntax error in expression "2#"}} +test expr-26.12 {error conditions} { + list [catch {expr a.b} msg] $msg +} {1 {syntax error in expression "a.b"}} +test expr-26.13 {error conditions} { + list [catch {expr {"a"/"b"}} msg] $msg +} {1 {can't use non-numeric string as operand of "/"}} +test expr-26.14 {error conditions} { + list [catch {expr 2:3} msg] $msg +} {1 {can't have : operator without ? first}} +test expr-26.15 {error conditions} { + list [catch {expr a@b} msg] $msg +} {1 {syntax error in expression "a@b"}} +test expr-26.16 {error conditions} { + list [catch {expr a[b} msg] $msg +} {1 {missing close-bracket}} +test expr-26.17 {error conditions} { + list [catch {expr a`b} msg] $msg +} {1 {syntax error in expression "a`b"}} +test expr-26.18 {error conditions} { + list [catch {expr \"a\"\{b} msg] $msg +} {1 {missing close-brace}} +test expr-26.19 {error conditions} { + list [catch {expr a} msg] $msg +} {1 {syntax error in expression "a"}} +test expr-26.20 {error conditions} { + list [catch expr msg] $msg +} {1 {wrong # args: should be "expr arg ?arg ...?"}} + +# Cancelled evaluation. + +test expr-27.1 {cancelled evaluation} { + set a 1 + expr {0&&[set a 2]} + set a +} 1 +test expr-27.2 {cancelled evaluation} { + set a 1 + expr {1||[set a 2]} + set a +} 1 +test expr-27.3 {cancelled evaluation} { + set a 1 + expr {0?[set a 2]:1} + set a +} 1 +test expr-27.4 {cancelled evaluation} { + set a 1 + expr {1?2:[set a 2]} + set a +} 1 +catch {unset x} +test expr-27.5 {cancelled evaluation} { + list [catch {expr {[info exists x] && $x}} msg] $msg +} {0 0} +test expr-27.6 {cancelled evaluation} { + list [catch {expr {0 && [concat $x]}} msg] $msg +} {0 0} + +# Tcl_ExprBool as used in "if" statements + +test expr-28.1 {Tcl_ExprBoolean usage} { + set a 1 + if {2} {set a 2} + set a +} 2 +test expr-28.2 {Tcl_ExprBoolean usage} { + set a 1 + if {0} {set a 2} + set a +} 1 +test expr-28.3 {Tcl_ExprBoolean usage} { + set a 1 + if {1.2} {set a 2} + set a +} 2 +test expr-28.4 {Tcl_ExprBoolean usage} { + set a 1 + if {-1.1} {set a 2} + set a +} 2 +test expr-28.5 {Tcl_ExprBoolean usage} { + set a 1 + if {0.0} {set a 2} + set a +} 1 +test expr-28.6 {Tcl_ExprBoolean usage} { + set a 1 + if {"YES"} {set a 2} + set a +} 2 +test expr-28.7 {Tcl_ExprBoolean usage} { + set a 1 + if {"no"} {set a 2} + set a +} 1 +test expr-28.8 {Tcl_ExprBoolean usage} { + set a 1 + if {"true"} {set a 2} + set a +} 2 +test expr-28.9 {Tcl_ExprBoolean usage} { + set a 1 + if {"fAlse"} {set a 2} + set a +} 1 +test expr-28.10 {Tcl_ExprBoolean usage} { + set a 1 + if {"on"} {set a 2} + set a +} 2 +test expr-28.11 {Tcl_ExprBoolean usage} { + set a 1 + if {"Off"} {set a 2} + set a +} 1 +test expr-28.12 {Tcl_ExprBool usage} { + list [catch {if {"abc"} {}} msg] $msg +} {1 {expected boolean value but got "abc"}} + +# Operands enclosed in braces + +test expr-29.1 {braces} {expr {{abc}}} abc +test expr-29.2 {braces} {expr {{00010}}} 8 +test expr-29.3 {braces} {expr {{3.1200000}}} 3.12 +test expr-29.4 {braces} {expr {{a{b}{1 {2 3}}c}}} "a{b}{1 {2 3}}c" +test expr-29.5 {braces} { + list [catch {expr "\{abc"} msg] $msg +} {1 {missing close-brace}} + +# Very long values + +test expr-30.1 {long values} { + set a "0000 1111 2222 3333 4444" + set a "$a | $a | $a | $a | $a" + set a "$a || $a || $a || $a || $a" + expr {$a} +} {0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 || 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 || 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 || 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 || 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444} +test expr-30.2 {long values} { + set a "000000000000000000000000000000" + set a "$a$a$a$a$a$a$a$a$a$a$a$a$a$a$a$a${a}5" + expr $a +} 5 + +# Expressions spanning multiple arguments + +test expr-31.1 {multiple arguments to expr command} { + expr 4 + ( 6 *12) -3 +} 73 +test expr-31.2 {multiple arguments to expr command} { + list [catch {expr 2 + (3 + 4} msg] $msg +} {1 {unmatched parentheses in expression "2 + (3 + 4"}} +test expr-31.3 {multiple arguments to expr command} { + list [catch {expr 2 + 3 +} msg] $msg +} {1 {syntax error in expression "2 + 3 +"}} +test expr-31.4 {multiple arguments to expr command} { + list [catch {expr 2 + 3 )} msg] $msg +} {1 {syntax error in expression "2 + 3 )"}} + +# Math functions + +test expr-32.1 {math functions in expressions} { + expr acos(0.5) +} {1.0472} +test expr-32.2 {math functions in expressions} { + expr asin(0.5) +} {0.523599} +test expr-32.3 {math functions in expressions} { + expr atan(1.0) +} {0.785398} +test expr-32.4 {math functions in expressions} { + expr atan2(2.0, 2.0) +} {0.785398} +test expr-32.5 {math functions in expressions} { + expr ceil(1.999) +} {2.0} +test expr-32.6 {math functions in expressions} { + expr cos(.1) +} {0.995004} +test expr-32.7 {math functions in expressions} { + expr cosh(.1) +} {1.005} +test expr-32.8 {math functions in expressions} { + expr exp(1.0) +} {2.71828} +test expr-32.9 {math functions in expressions} { + expr floor(2.000) +} {2.0} +test expr-32.10 {math functions in expressions} { + expr floor(2.001) +} {2.0} +test expr-32.11 {math functions in expressions} { + expr fmod(7.3, 3.2) +} {0.9} +test expr-32.12 {math functions in expressions} { + expr hypot(3.0, 4.0) +} {5.0} +test expr-32.13 {math functions in expressions} { + expr log(2.8) +} {1.02962} +test expr-32.14 {math functions in expressions} { + expr log10(2.8) +} {0.447158} +test expr-32.15 {math functions in expressions} { + expr pow(2.1, 3.1) +} {9.97424} +test expr-32.16 {math functions in expressions} { + expr sin(.1) +} {0.0998334} +test expr-32.17 {math functions in expressions} { + expr sinh(.1) +} {0.100167} +test expr-32.18 {math functions in expressions} { + expr sqrt(2.0) +} {1.41421} +test expr-32.19 {math functions in expressions} { + expr tan(0.8) +} {1.02964} +test expr-32.20 {math functions in expressions} { + expr tanh(0.8) +} {0.664037} +test expr-32.21 {math functions in expressions} { + expr abs(-1.8) +} {1.8} +test expr-32.22 {math functions in expressions} { + expr abs(10.0) +} {10.0} +test expr-32.23 {math functions in expressions} { + expr abs(-4) +} {4} +test expr-32.24 {math functions in expressions} { + expr abs(66) +} {66} +if ($atBerkeley) { + test expr-32.25 {math functions in expressions} { + list [catch {expr abs(0x80000000)} msg] $msg + } {1 {integer value too large to represent}} +} +test expr-32.26 {math functions in expressions} { + expr double(1) +} {1.0} +test expr-32.27 {math functions in expressions} { + expr double(1.1) +} {1.1} +test expr-32.28 {math functions in expressions} { + expr int(1) +} {1} +test expr-32.29 {math functions in expressions} { + expr int(1.4) +} {1} +test expr-32.30 {math functions in expressions} { + expr int(1.6) +} {1} +test expr-32.31 {math functions in expressions} { + expr int(-1.4) +} {-1} +test expr-32.32 {math functions in expressions} { + expr int(-1.6) +} {-1} +test expr-32.33 {math functions in expressions} { + list [catch {expr int(1e60)} msg] $msg +} {1 {integer value too large to represent}} +test expr-32.34 {math functions in expressions} { + list [catch {expr int(-1e60)} msg] $msg +} {1 {integer value too large to represent}} +test expr-32.35 {math functions in expressions} { + expr round(1.49) +} {1} +test expr-32.36 {math functions in expressions} { + expr round(1.51) +} {2} +test expr-32.37 {math functions in expressions} { + expr round(-1.49) +} {-1} +test expr-32.38 {math functions in expressions} { + expr round(-1.51) +} {-2} +test expr-32.39 {math functions in expressions} { + list [catch {expr round(1e60)} msg] $msg +} {1 {integer value too large to represent}} +test expr-32.40 {math functions in expressions} { + list [catch {expr round(-1e60)} msg] $msg +} {1 {integer value too large to represent}} +test expr-32.41 {math functions in expressions} { + list [catch {expr pow(1.0 + 3.0 - 2, .8 * 5)} msg] $msg +} {0 16.0} +test expr-32.42 {math functions in expressions} { + list [catch {expr hypot(5*.8,3)} msg] $msg +} {0 5.0} +if $gotT1 { + test expr-32.43 {math functions in expressions} { + expr 2*T1() + } 246 + test expr-32.44 {math functions in expressions} { + expr T2()*3 + } 1035 +} + +test expr-33.1 {conversions and fancy args to math functions} { + expr hypot ( 3 , 4 ) +} 5.0 +test expr-33.2 {conversions and fancy args to math functions} { + expr hypot ( (2.0+1.0) , 4 ) +} 5.0 +test expr-33.3 {conversions and fancy args to math functions} { + expr hypot ( 3 , (3.0 + 1.0) ) +} 5.0 +test expr-33.4 {conversions and fancy args to math functions} { + expr cos(acos(0.1)) +} 0.1 + +test expr-34.1 {errors in math functions} { + list [catch {expr func_2(1.0)} msg] $msg +} {1 {unknown math function "func_2"}} +test expr-34.2 {errors in math functions} { + list [catch {expr func|(1.0)} msg] $msg +} {1 {syntax error in expression "func|(1.0)"}} +test expr-34.3 {errors in math functions} { + list [catch {expr {hypot("a b", 2.0)}} msg] $msg +} {1 {argument to math function didn't have numeric value}} +test expr-34.4 {errors in math functions} { + list [catch {expr hypot(1.0 2.0)} msg] $msg +} {1 {syntax error in expression "hypot(1.0 2.0)"}} +test expr-34.5 {errors in math functions} { + list [catch {expr hypot(1.0, 2.0} msg] $msg +} {1 {syntax error in expression "hypot(1.0, 2.0"}} +test expr-34.6 {errors in math functions} { + list [catch {expr hypot(1.0 ,} msg] $msg +} {1 {syntax error in expression "hypot(1.0 ,"}} +test expr-34.7 {errors in math functions} { + list [catch {expr hypot(1.0)} msg] $msg +} {1 {too few arguments for math function}} +test expr-34.8 {errors in math functions} { + list [catch {expr hypot(1.0, 2.0, 3.0)} msg] $msg +} {1 {too many arguments for math function}} +test expr-34.9 {errors in math functions} { + list [catch {expr acos(-2.0)} msg] $msg $errorCode +} {1 {domain error: argument not in valid range} {ARITH DOMAIN {domain error: argument not in valid range}}} +if $atBerkeley { + test expr-34.10 {errors in math functions} { + list [catch {expr pow(-3, 1000001)} msg] $msg $errorCode + } {1 {floating-point value too large to represent} {ARITH OVERFLOW {floating-point value too large to represent}}} +} +test expr-34.11 {errors in math functions} { + list [catch {expr pow(3, 1000001)} msg] $msg $errorCode +} {1 {floating-point value too large to represent} {ARITH OVERFLOW {floating-point value too large to represent}}} +test expr-34.12 {errors in math functions} { + list [catch {expr -14.0*exp(100000)} msg] $msg $errorCode +} {1 {floating-point value too large to represent} {ARITH OVERFLOW {floating-point value too large to represent}}} +test expr-34.13 {errors in math functions} { + list [catch {expr int(1.0e30)} msg] $msg $errorCode +} {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}} +test expr-34.14 {errors in math functions} { + list [catch {expr int(-1.0e30)} msg] $msg $errorCode +} {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}} +test expr-34.15 {errors in math functions} { + list [catch {expr round(1.0e30)} msg] $msg $errorCode +} {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}} +test expr-34.16 {errors in math functions} { + list [catch {expr round(-1.0e30)} msg] $msg $errorCode +} {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}} +if $gotT1 { + test expr-34.17 {errors in math functions} { + list [catch {expr T1(4)} msg] $msg + } {1 {syntax error in expression "T1(4)"}} +} + +catch {unset tcl_precision} +test expr-35.1 {tcl_precision variable} { + expr 2.0/3 +} 0.666667 +set tcl_precision 1 +test expr-35.2 {tcl_precision variable} { + expr 2.0/3 +} 0.7 +test expr-35.3 {tcl_precision variable} { + expr 2.0/3 +} 0.7 +test expr-35.4 {tcl_precision variable} { + list [catch {set tcl_precision 0} msg] $msg [expr 2.0/3] +} {1 {can't set "tcl_precision": improper value for precision} 0.7} +test expr-35.5 {tcl_precision variable} { + list [catch {set tcl_precision 101} msg] $msg [expr 2.0/3] +} {1 {can't set "tcl_precision": improper value for precision} 0.7} +test expr-35.6 {tcl_precision variable} { + list [catch {set tcl_precision {}} msg] $msg [expr 2.0/3] +} {1 {can't set "tcl_precision": improper value for precision} 0.7} +test expr-35.7 {tcl_precision variable} { + list [catch {set tcl_precision {1 2 3}} msg] $msg [expr 2.0/3] +} {1 {can't set "tcl_precision": improper value for precision} 0.7} +catch {unset tcl_precision} +test expr-35.8 {tcl_precision variable} { + expr 2.0/3 +} 0.666667 diff --git a/vendor/x11iraf/obm/Tcl/tests/file.test b/vendor/x11iraf/obm/Tcl/tests/file.test new file mode 100644 index 00000000..83603342 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/tests/file.test @@ -0,0 +1,326 @@ +# Commands covered: file +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1991-1993 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. +# +# $Header: /user6/ouster/tcl/tests/RCS/file.test,v 1.22 93/04/16 16:46:42 ouster Exp $ (Berkeley) + +if {[string compare test [info procs test]] == 1} then {source defs} + +# rootname and ext + +test file-1.1 {rootname and extension options} {file ext abc.def} .def +test file-1.2 {rootname and extension options} {file ro abc.def} abc +test file-1.3 {rootname and extension options} {file extension a/b/c.d} .d +test file-1.4 {rootname and extension options} {file rootname a/b/c.d} a/b/c +test file-1.5 {rootname and extension options} {file extension a/b.c/d} {} +test file-1.6 {rootname and extension options} {file rootname a/b.c/d} a/b.c/d +set num 7 +foreach outer { {} a .a a. a.a } { + foreach inner { {} a .a a. a.a } { + set thing [format %s/%s $outer $inner] + test file-1.$num {rootname and extension options} { + format %s%s [file rootname $thing] [file ext $thing] + } $thing + set num [expr $num+1] + } +} + +# dirname and tail + +test file-2.1 {dirname and tail options} {file dirname .def} . +test file-2.2 {dirname and tail options} {file tail abc.def} abc.def +test file-2.3 {dirname and tail options} {file d a/b/c.d} a/b +test file-2.4 {dirname and tail options} {file ta a/b/c.d} c.d +test file-2.5 {dirname and tail options} {file dirname a/b.c/d} a/b.c +test file-2.6 {dirname and tail options} {file tail a/b.c/d} d +set num 7 +foreach outer { a .a a. a.a } { + foreach inner { {} a .a a. a.a } { + set thing [format %s/%s $outer $inner] + test file-2.$num {dirname and tail options} { + format %s/%s [file dirname $thing] [file tail $thing] + } $thing + set num [expr $num+1] + } +} + +# exists + +catch {exec chmod 777 dir.file} +catch {exec rm -f dir.file/gorp.file} +catch {exec rm -f gorp.file} +catch {exec rmdir dir.file} +catch {exec rm -f link.file} +test file-3.1 {exists option} {file exists gorp.file} 0 +test file-3.2 {exists option} {file exists dir.file/gorp.file} 0 +exec cat > gorp.file << abcde +exec mkdir dir.file +exec cat > dir.file/gorp.file << 12345 +test file-3.3 {exists option} {file exists gorp.file} 1 +test file-3.4 {exists option} {file exi dir.file/gorp.file} 1 + +# The test below has to be done in /tmp rather than the current +# directory in order to guarantee (?) a local file system: some +# NFS file systems won't do the stuff below correctly. + +catch {exec rm /tmp/tcl.foo.dir/file} +catch {exec rmdir /tmp/tcl.foo.dir} +exec mkdir /tmp/tcl.foo.dir +exec cat > /tmp/tcl.foo.dir/file << 12345 +exec chmod 000 /tmp/tcl.foo.dir +if {$user != "root"} { + test file-3.5 {exists option} {file exists /tmp/tcl.foo.dir/file} 0 +} +exec chmod 775 /tmp/tcl.foo.dir +exec rm /tmp/tcl.foo.dir/file +exec rmdir /tmp/tcl.foo.dir + +# executable + +exec chmod 000 dir.file +if {$user != "root"} { + test file-4.1 {executable option} {file executable gorp.file} 0 +} +exec chmod 775 gorp.file +test file-4.2 {executable option} {file exe gorp.file} 1 + +# isdirectory + +test file-5.1 {isdirectory option} {file isdirectory gorp.file} 0 +test file-5.2 {isdirectory option} {file isd dir.file} 1 + +# isfile + +test file-6.1 {isfile option} {file isfile gorp.file} 1 +test file-6.2 {isfile option} {file isfile dir.file} 0 + +# isowned + +test file-7.1 {owned option} {file owned gorp.file} 1 +if {$user != "root"} { + test file-7.2 {owned option} {file owned /} 0 +} + +# readable + +exec chmod 444 gorp.file +test file-8.1 {readable option} {file readable gorp.file} 1 +exec chmod 333 gorp.file +if {$user != "root"} { + test file-8.2 {readable option} {file reada gorp.file} 0 +} + +# writable + +exec chmod 555 gorp.file +if {$user != "root"} { + test file-9.1 {writable option} {file writable gorp.file} 0 +} +exec chmod 222 gorp.file +test file-9.2 {writable option} {file w gorp.file} 1 + +# stat + +exec cat > gorp.file << "Test string" +exec chmod 765 gorp.file +test file-10.1 {stat option} { + catch {unset stat} + file stat gorp.file stat + lsort [array names stat] +} {atime ctime dev gid ino mode mtime nlink size type uid} +test file-10.2 {stat option} { + catch {unset stat} + file stat gorp.file stat + list $stat(nlink) $stat(size) [expr $stat(mode)&0777] $stat(type) +} {1 11 501 file} +test file-10.3 {stat option} { + string tolower [list [catch {file stat _bogus_ stat} msg] \ + $msg $errorCode] +} {1 {couldn't stat "_bogus_": no such file or directory} {posix enoent {no such file or directory}}} +test file-10.4 {stat option} { + list [catch {file stat _bogus_} msg] $msg $errorCode +} {1 {wrong # args: should be "file stat name varName"} NONE} +test file-10.5 {stat option} { + list [catch {file stat _bogus_ a b} msg] $msg $errorCode +} {1 {wrong # args: should be "file stat name varName"} NONE} +test file-10.6 {stat option} { + catch {unset x} + set x 44 + list [catch {file stat gorp.file x} msg] $msg $errorCode +} {1 {can't set "x(dev)": variable isn't array} NONE} +catch {unset stat} + +# mtime, and size (I've given up trying to find a test for "atime": there +# seem to be too many quirks in the way file systems handle this to come +# up with a reproducible test). + +test file-11.1 {mtime and atime and size options} { + catch {unset stat} + file stat gorp.file stat + list [expr {[file mtime gorp.file] == $stat(mtime)}] \ + [expr {[file atime gorp.file] == $stat(atime)}] \ + [file size gorp.file] +} {1 1 11} +test file-11.2 {mtime option} { + set old [file mtime gorp.file] + exec sleep 2 + set f [open gorp.file w] + puts $f "More text" + close $f + set new [file mtime gorp.file] + expr {($new > $old) && ($new <= ($old+5))} +} {1} +test file-11.3 {size option} { + set oldsize [file size gorp.file] + set f [open gorp.file a] + puts $f "More text" + close $f + expr {[file size gorp.file] - $oldsize} +} {10} +test file-11.4 {errors in atime option} { + list [catch {file atime _bogus_ x} msg] $msg $errorCode +} {1 {wrong # args: should be "file atime name"} NONE} +test file-11.5 {errors in atime option} { + string tolower [list [catch {file atime _bogus_} msg] \ + $msg $errorCode] +} {1 {couldn't stat "_bogus_": no such file or directory} {posix enoent {no such file or directory}}} +test file-11.6 {errors in mtime option} { + list [catch {file mtime _bogus_ x} msg] $msg $errorCode +} {1 {wrong # args: should be "file mtime name"} NONE} +test file-11.7 {errors in mtime option} { + string tolower [list [catch {file mtime _bogus_} msg] $msg \ + $errorCode] +} {1 {couldn't stat "_bogus_": no such file or directory} {posix enoent {no such file or directory}}} +test file-11.8 {errors in size option} { + list [catch {file size _bogus_ x} msg] $msg $errorCode +} {1 {wrong # args: should be "file size name"} NONE} +test file-11.9 {errors in size option} { + string tolower [list [catch {file size _bogus_} msg] $msg \ + $errorCode] +} {1 {couldn't stat "_bogus_": no such file or directory} {posix enoent {no such file or directory}}} + +# type + +test file-12.1 {type option} { + file type dir.file +} directory +test file-12.2 {type option} { + file type gorp.file +} file +if $atBerkeley { + exec ln -s a/b/c link.file + test file-12.3 {type option} { + file type link.file + } link + exec rm link.file +} +test file-12.4 {errors in type option} { + list [catch {file type a b} msg] $msg $errorCode +} {1 {wrong # args: should be "file type name"} NONE} +test file-12.5 {errors in type option} { + string tolower [list [catch {file type _bogus_} msg] $msg $errorCode] +} {1 {couldn't stat "_bogus_": no such file or directory} {posix enoent {no such file or directory}}} + +# lstat and readlink: run these tests only at Berkeley, since not all +# sites will have symbolic links + +if $atBerkeley { + exec ln -s gorp.file link.file + test file-13.1 {lstat option} { + catch {unset stat} + file lstat link.file stat + lsort [array names stat] + } {atime ctime dev gid ino mode mtime nlink size type uid} + test file-13.1 {lstat option} { + catch {unset stat} + file lstat link.file stat + list $stat(nlink) [expr $stat(mode)&0777] $stat(type) + } {1 511 link} + test file-13.3 {errors in lstat option} { + string tolower [list [catch {file lstat _bogus_ stat} msg] \ + $msg $errorCode] + } {1 {couldn't lstat "_bogus_": no such file or directory} {posix enoent {no such file or directory}}} + test file-13.4 {errors in lstat option} { + list [catch {file lstat _bogus_} msg] $msg $errorCode + } {1 {wrong # args: should be "file lstat name varName"} NONE} + test file-13.5 {errors in lstat option} { + list [catch {file lstat _bogus_ a b} msg] $msg $errorCode + } {1 {wrong # args: should be "file lstat name varName"} NONE} + test file-13.6 {errors in lstat option} { + catch {unset x} + set x 44 + list [catch {file lstat gorp.file x} msg] $msg $errorCode + } {1 {can't set "x(dev)": variable isn't array} NONE} + catch {unset stat} + + test file-14.1 {readlink option} { + file readlink link.file + } gorp.file + test file-14.2 {errors in readlink option} { + list [catch {file readlink a b} msg] $msg $errorCode + } {1 {wrong # args: should be "file readlink name"} NONE} + test file-14.3 {errors in readlink option} { + list [catch {file readlink _bogus_} msg] $msg $errorCode + } {1 {couldn't readlink "_bogus_": no such file or directory} {POSIX ENOENT {no such file or directory}}} + + exec rm link.file +} + +# Error conditions + +test file-15.1 {error conditions} { + list [catch file msg] $msg +} {1 {wrong # args: should be "file option name ?arg ...?"}} +test file-15.2 {error conditions} { + list [catch {file x} msg] $msg +} {1 {wrong # args: should be "file option name ?arg ...?"}} +test file-15.3 {error conditions} { + list [catch {file exists x too} msg] $msg +} {1 {wrong # args: should be "file exists name"}} +test file-15.4 {error conditions} { + list [catch {file gorp x} msg] $msg +} {1 {bad option "gorp": should be atime, dirname, executable, exists, extension, isdirectory, isfile, lstat, mtime, owned, readable, readlink, root, size, stat, tail, type, or writable}} +test file-15.5 {error conditions} { + list [catch {file ex x} msg] $msg +} {1 {bad option "ex": should be atime, dirname, executable, exists, extension, isdirectory, isfile, lstat, mtime, owned, readable, readlink, root, size, stat, tail, type, or writable}} +test file-15.6 {error conditions} { + list [catch {file is x} msg] $msg +} {1 {bad option "is": should be atime, dirname, executable, exists, extension, isdirectory, isfile, lstat, mtime, owned, readable, readlink, root, size, stat, tail, type, or writable}} +test file-15.7 {error conditions} { + list [catch {file read x} msg] $msg +} {1 {bad option "read": should be atime, dirname, executable, exists, extension, isdirectory, isfile, lstat, mtime, owned, readable, readlink, root, size, stat, tail, type, or writable}} +test file-15.8 {error conditions} { + list [catch {file s x} msg] $msg +} {1 {bad option "s": should be atime, dirname, executable, exists, extension, isdirectory, isfile, lstat, mtime, owned, readable, readlink, root, size, stat, tail, type, or writable}} +test file-15.9 {error conditions} { + list [catch {file t x} msg] $msg +} {1 {bad option "t": should be atime, dirname, executable, exists, extension, isdirectory, isfile, lstat, mtime, owned, readable, readlink, root, size, stat, tail, type, or writable}} +test file-15.10 {error conditions} { + list [catch {file rootname ~woohgy} msg] $msg +} {1 {user "woohgy" doesn't exist}} + +exec chmod 777 dir.file +exec rm dir.file/gorp.file gorp.file +exec rmdir dir.file diff --git a/vendor/x11iraf/obm/Tcl/tests/for.test b/vendor/x11iraf/obm/Tcl/tests/for.test new file mode 100644 index 00000000..2fafcc5a --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/tests/for.test @@ -0,0 +1,169 @@ +# Commands covered: foreach, for, continue, break +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1991-1993 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. +# +# $Header: /user6/ouster/tcl/tests/RCS/for.test,v 1.8 93/02/06 15:54:05 ouster Exp $ (Berkeley) + +if {[string compare test [info procs test]] == 1} then {source defs} + +# Basic "foreach" operation. + +test for-1.1 {basic foreach tests} { + set a {} + foreach i {a b c d} { + set a [concat $a $i] + } + set a +} {a b c d} +test for-1.2 {basic foreach tests} { + set a {} + foreach i {a b {{c d} e} {123 {{x}}}} { + set a [concat $a $i] + } + set a +} {a b {c d} e 123 {{x}}} +test for-1.3 {basic foreach tests} {catch {foreach} msg} 1 +test for-1.4 {basic foreach tests} { + catch {foreach} msg + set msg +} {wrong # args: should be "foreach varName list command"} +test for-1.5 {basic foreach tests} {catch {foreach i} msg} 1 +test for-1.6 {basic foreach tests} { + catch {foreach i} msg + set msg +} {wrong # args: should be "foreach varName list command"} +test for-1.7 {basic foreach tests} {catch {foreach i j} msg} 1 +test for-1.8 {basic foreach tests} { + catch {foreach i j} msg + set msg +} {wrong # args: should be "foreach varName list command"} +test for-1.9 {basic foreach tests} {catch {foreach i j k l} msg} 1 +test for-1.10 {basic foreach tests} { + catch {foreach i j k l} msg + set msg +} {wrong # args: should be "foreach varName list command"} +test for-1.11 {basic foreach tests} { + set a {} + foreach i {} { + set a [concat $a $i] + } + set a +} {} +test for-1.11 {foreach errors} { + catch {unset a} + set a(0) 44 + list [catch {foreach a {1 2 3} {}} msg] $msg +} {1 {couldn't set loop variable}} +catch {unset a} + +# Check "continue". + +test for-2.1 {continue tests} {catch continue} 4 +test for-2.2 {continue tests} { + set a {} + foreach i {a b c d} { + if {[string compare $i "b"] == 0} continue + set a [concat $a $i] + } + set a +} {a c d} +test for-2.3 {continue tests} { + set a {} + foreach i {a b c d} { + if {[string compare $i "b"] != 0} continue + set a [concat $a $i] + } + set a +} {b} +test for-2.4 {continue tests} {catch {continue foo} msg} 1 +test for-2.5 {continue tests} { + catch {continue foo} msg + set msg +} {wrong # args: should be "continue"} + +# Check "break". + +test for-3.1 {break tests} {catch break} 3 +test for-3.2 {break tests} { + set a {} + foreach i {a b c d} { + if {[string compare $i "c"] == 0} break + set a [concat $a $i] + } + set a +} {a b} +test for-3.3 {break tests} {catch {break foo} msg} 1 +test for-3.4 {break tests} { + catch {break foo} msg + set msg +} {wrong # args: should be "break"} + +# Check "for" and its use of continue and break. + +test for-4.1 {for tests} { + set a {} + for {set i 1} {$i<6} {set i [expr $i+1]} { + set a [concat $a $i] + } + set a +} {1 2 3 4 5} +test for-4.2 {for tests} { + set a {} + for {set i 1} {$i<6} {set i [expr $i+1]} { + if $i==4 continue + set a [concat $a $i] + } + set a +} {1 2 3 5} +test for-4.3 {for tests} { + set a {} + for {set i 1} {$i<6} {set i [expr $i+1]} { + if $i==4 break + set a [concat $a $i] + } + set a +} {1 2 3} +test for-4.4 {for tests} {catch {for 1 2 3} msg} 1 +test for-4.5 {for tests} { + catch {for 1 2 3} msg + set msg +} {wrong # args: should be "for start test next command"} +test for-4.6 {for tests} {catch {for 1 2 3 4 5} msg} 1 +test for-4.7 {for tests} { + catch {for 1 2 3 4 5} msg + set msg +} {wrong # args: should be "for start test next command"} +test for-4.8 {for tests} { + set a {xyz} + for {set i 1} {$i<6} {set i [expr $i+1]} {} + set a +} xyz +test for-4.9 {for tests} { + set a {} + for {set i 1} {$i<6} {set i [expr $i+1]; if $i==4 break} { + set a [concat $a $i] + } + set a +} {1 2 3} diff --git a/vendor/x11iraf/obm/Tcl/tests/format.test b/vendor/x11iraf/obm/Tcl/tests/format.test new file mode 100644 index 00000000..e31ba501 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/tests/format.test @@ -0,0 +1,379 @@ +# Commands covered: format +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1991-1993 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. +# +# $Header: /user6/ouster/tcl/tests/RCS/format.test,v 1.16 93/07/17 15:25:01 ouster Exp $ (Berkeley) + +if {[string compare test [info procs test]] == 1} then {source defs} + +# The following code is needed because some versions of SCO Unix have +# a round-off error in sprintf which would cause some of the tests to +# fail. Someday I hope this code shouldn't be necessary (code added +# 9/9/91). + +set roundOffBug 0 +if {"[format %7.1e 68.514]" == "6.8e+01"} { + puts stdout "Note: this system has a sprintf round-off bug, some tests skipped\n" + set roundOffBug 1 +} + +test format-1.1 {integer formatting} { + format "%*d %d %d %d" 6 34 16923 -12 -1 +} { 34 16923 -12 -1} +if $atBerkeley { + test format-1.2 {integer formatting} { + format "%4d %4d %4d %4d %d %#x %#X" 6 34 16923 -12 -1 0 0 + } { 6 34 16923 -12 -1 0 0} +} + +# %u output depends on word length, so don't run these tests except +# at Berkeley, where word length is known. + +if $atBerkeley { + test format-1.3 {integer formatting} { + format "%4u %4u %4u %4u %d %#o" 6 34 16923 -12 -1 0 + } { 6 34 16923 4294967284 -1 0} +} +test format-1.4 {integer formatting} { + format "%-4d %-4i %-4d %-4ld" 6 34 16923 -12 -1 +} {6 34 16923 -12 } +test format-1.5 {integer formatting} { + format "%04d %04d %04d %04i" 6 34 16923 -12 -1 +} {0006 0034 16923 -012} +test format-1.6 {integer formatting} { + format "%00*d" 6 34 +} {000034} + +# Printing negative numbers in hex or octal format depends on word +# length; only run at Berkeley where word length is known. + +if $atBerkeley { + test format-1.7 {integer formatting} { + format "%4x %4x %4x %4x" 6 34 16923 -12 -1 + } { 6 22 421b fffffff4} + test format-1.8 {integer formatting} { + format "%#x %#X %#X %#x" 6 34 16923 -12 -1 + } {0x6 0X22 0X421B 0xfffffff4} + test format-1.9 {integer formatting} { + format "%#20x %#20x %#20x %#20x" 6 34 16923 -12 -1 + } { 0x6 0x22 0x421b 0xfffffff4} + test format-1.10 {integer formatting} { + format "%-#20x %-#20x %-#20x %-#20x" 6 34 16923 -12 -1 + } {0x6 0x22 0x421b 0xfffffff4 } + test format-1.11 {integer formatting} { + format "%-#20o %#-20o %#-20o %#-20o" 6 34 16923 -12 -1 + } {06 042 041033 037777777764 } +} + +test format-2.1 {string formatting} { + format "%s %s %c %s" abcd {This is a very long test string.} 120 x +} {abcd This is a very long test string. x x} +test format-2.2 {string formatting} { + format "%20s %20s %20c %20s" abcd {This is a very long test string.} 120 x +} { abcd This is a very long test string. x x} +test format-2.3 {string formatting} { + format "%.10s %.10s %c %.10s" abcd {This is a very long test string.} 120 x +} {abcd This is a x x} +test format-2.4 {string formatting} { + format "%s %s %% %c %s" abcd {This is a very long test string.} 120 x +} {abcd This is a very long test string. % x x} + +test format-3.1 {e and f formats} { + format "%e %e %e %e" 34.2e12 68.514 -.125 -16000. .000053 +} {3.420000e+13 6.851400e+01 -1.250000e-01 -1.600000e+04} +test format-3.2 {e and f formats} { + format "%20e %20e %20e %20e" 34.2e12 68.514 -.125 -16000. .000053 +} { 3.420000e+13 6.851400e+01 -1.250000e-01 -1.600000e+04} +if {!$roundOffBug} { + test format-3.3 {e and f formats} { + format "%.1e %.1e %.1e %.1e" 34.2e12 68.514 -.126 -16000. .000053 + } {3.4e+13 6.9e+01 -1.3e-01 -1.6e+04} + test format-3.4 {e and f formats} { + format "%020e %020e %020e %020e" 34.2e12 68.514 -.126 -16000. .000053 + } {000000003.420000e+13 000000006.851400e+01 -00000001.260000e-01 -00000001.600000e+04} + test format-3.5 {e and f formats} { + format "%7.1e %7.1e %7.1e %7.1e" 34.2e12 68.514 -.126 -16000. .000053 + } {3.4e+13 6.9e+01 -1.3e-01 -1.6e+04} + test format-3.6 {e and f formats} { + format "%f %f %f %f" 34.2e12 68.514 -.125 -16000. .000053 + } {34200000000000.000000 68.514000 -0.125000 -16000.000000} +} +test format-3.7 {e and f formats} { + format "%.4f %.4f %.4f %.4f %.4f" 34.2e12 68.514 -.125 -16000. .000053 +} {34200000000000.0000 68.5140 -0.1250 -16000.0000 0.0001} +test format-3.8 {e and f formats} { + format "%.4e %.5e %.6e" -9.99996 -9.99996 9.99996 +} {-1.0000e+01 -9.99996e+00 9.999960e+00} +test format-3.9 {e and f formats} { + format "%.4f %.5f %.6f" -9.99996 -9.99996 9.99996 +} {-10.0000 -9.99996 9.999960} +test format-3.10 {e and f formats} { + format "%20f %-20f %020f" -9.99996 -9.99996 9.99996 +} { -9.999960 -9.999960 0000000000009.999960} +test format-3.11 {e and f formats} { + format "%-020f %020f" -9.99996 -9.99996 9.99996 +} {-9.999960 -000000000009.999960} +test format-3.12 {e and f formats} { + format "%.0e %#.0e" -9.99996 -9.99996 9.99996 +} {-1e+01 -1.e+01} +test format-3.13 {e and f formats} { + format "%.0f %#.0f" -9.99996 -9.99996 9.99996 +} {-10 -10.} +test format-3.14 {e and f formats} { + format "%.4f %.5f %.6f" -9.99996 -9.99996 9.99996 +} {-10.0000 -9.99996 9.999960} +test format-3.15 {e and f formats} { + format "%3.0f %3.0f %3.0f %3.0f" 1.0 1.1 1.01 1.001 +} { 1 1 1 1} +test format-3.16 {e and f formats} { + format "%3.1f %3.1f %3.1f %3.1f" 0.0 0.1 0.01 0.001 +} {0.0 0.1 0.0 0.0} + +test format-4.1 {g-format} { + format "%.3g" 12341.0 +} {1.23e+04} +test format-4.2 {g-format} { + format "%.3G" 1234.12345 +} {1.23E+03} +test format-4.3 {g-format} { + format "%.3g" 123.412345 +} {123} +test format-4.4 {g-format} { + format "%.3g" 12.3412345 +} {12.3} +test format-4.5 {g-format} { + format "%.3g" 1.23412345 +} {1.23} +test format-4.6 {g-format} { + format "%.3g" 1.23412345 +} {1.23} +test format-4.7 {g-format} { + format "%.3g" .123412345 +} {0.123} +test format-4.8 {g-format} { + format "%.3g" .012341 +} {0.0123} +test format-4.9 {g-format} { + format "%.3g" .0012341 +} {0.00123} +test format-4.10 {g-format} { + format "%.3g" .00012341 +} {0.000123} +test format-4.11 {g-format} { + format "%.3g" .00001234 +} {1.23e-05} +test format-4.12 {g-format} { + format "%.4g" 9999.6 +} {1e+04} +test format-4.13 {g-format} { + format "%.4g" 999.96 +} {1000} +test format-4.14 {g-format} { + format "%.3g" 1.0 +} {1} +test format-4.15 {g-format} { + format "%.3g" .1 +} {0.1} +test format-4.16 {g-format} { + format "%.3g" .01 +} {0.01} +test format-4.17 {g-format} { + format "%.3g" .001 +} {0.001} +test format-4.19 {g-format} { + format "%.3g" .00001 +} {1e-05} +test format-4.20 {g-format} { + format "%#.3g" 1234.0 +} {1.23e+03} +test format-4.21 {g-format} { + format "%#.3G" 9999.5 +} {1.00E+04} + +test format-5.1 {floating-point zeroes} { + format "%e %f %g" 0.0 0.0 0.0 0.0 +} {0.000000e+00 0.000000 0} +test format-5.2 {floating-point zeroes} { + format "%.4e %.4f %.4g" 0.0 0.0 0.0 0.0 +} {0.0000e+00 0.0000 0} +test format-5.3 {floating-point zeroes} { + format "%#.4e %#.4f %#.4g" 0.0 0.0 0.0 0.0 +} {0.0000e+00 0.0000 0.000} +test format-5.4 {floating-point zeroes} { + format "%.0e %.0f %.0g" 0.0 0.0 0.0 0.0 +} {0e+00 0 0} +test format-5.5 {floating-point zeroes} { + format "%#.0e %#.0f %#.0g" 0.0 0.0 0.0 0.0 +} {0.e+00 0. 0.} +test format-5.6 {floating-point zeroes} { + format "%3.0f %3.0f %3.0f %3.0f" 0.0 0.0 0.0 0.0 +} { 0 0 0 0} +test format-5.7 {floating-point zeroes} { + format "%3.0f %3.0f %3.0f %3.0f" 1.0 1.1 1.01 1.001 +} { 1 1 1 1} +test format-5.8 {floating-point zeroes} { + format "%3.1f %3.1f %3.1f %3.1f" 0.0 0.1 0.01 0.001 +} {0.0 0.1 0.0 0.0} + +test format-6.1 {various syntax features} { + format "%*.*f" 12 3 12.345678901 +} { 12.346} +test format-6.2 {various syntax features} { + format "%0*.*f" 12 3 12.345678901 +} {00000012.346} +test format-6.3 {various syntax features} { + format "\*\t\\n" +} {* \n} + +test format-7.1 {error conditions} { + catch format +} 1 +test format-7.2 {error conditions} { + catch format msg + set msg +} {wrong # args: should be "format formatString ?arg arg ...?"} +test format-7.3 {error conditions} { + catch {format %*d} +} 1 +test format-7.4 {error conditions} { + catch {format %*d} msg + set msg +} {not enough arguments for all format specifiers} +test format-7.5 {error conditions} { + catch {format %*.*f 12} +} 1 +test format-7.6 {error conditions} { + catch {format %*.*f 12} msg + set msg +} {not enough arguments for all format specifiers} +test format-7.7 {error conditions} { + catch {format %*.*f 12 3} +} 1 +test format-7.8 {error conditions} { + catch {format %*.*f 12 3} msg + set msg +} {not enough arguments for all format specifiers} +test format-7.9 {error conditions} { + list [catch {format %*d x 3} msg] $msg +} {1 {expected integer but got "x"}} +test format-7.10 {error conditions} { + list [catch {format %*.*f 2 xyz 3} msg] $msg +} {1 {expected integer but got "xyz"}} +test format-7.11 {error conditions} { + catch {format %d 2a} +} 1 +test format-7.12 {error conditions} { + catch {format %d 2a} msg + set msg +} {expected integer but got "2a"} +test format-7.13 {error conditions} { + catch {format %c 2x} +} 1 +test format-7.14 {error conditions} { + catch {format %c 2x} msg + set msg +} {expected integer but got "2x"} +test format-7.15 {error conditions} { + catch {format %f 2.1z} +} 1 +test format-7.16 {error conditions} { + catch {format %f 2.1z} msg + set msg +} {expected floating-point number but got "2.1z"} +test format-7.17 {error conditions} { + catch {format ab%} +} 1 +test format-7.18 {error conditions} { + catch {format ab% 12} msg + set msg +} {format string ended in middle of field specifier} +test format-7.19 {error conditions} { + catch {format %q x} +} 1 +test format-7.20 {error conditions} { + catch {format %q x} msg + set msg +} {bad field specifier "q"} +test format-7.21 {error conditions} { + catch {format %d} +} 1 +test format-7.22 {error conditions} { + catch {format %d} msg + set msg +} {not enough arguments for all format specifiers} + +test format-8.1 {long result} { + set a {1234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ 1 2 3 4 5 6 7 8 9 0 a b c d e f g h i j k l m n o p q r s t u v w x y z A B C D E F G H I J K L M N O P Q R S T U V W X Y Z} + format {1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG %s %s %s} $a $a $a +} {1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG 1234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ 1 2 3 4 5 6 7 8 9 0 a b c d e f g h i j k l m n o p q r s t u v w x y z A B C D E F G H I J K L M N O P Q R S T U V W X Y Z 1234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ 1 2 3 4 5 6 7 8 9 0 a b c d e f g h i j k l m n o p q r s t u v w x y z A B C D E F G H I J K L M N O P Q R S T U V W X Y Z 1234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ 1 2 3 4 5 6 7 8 9 0 a b c d e f g h i j k l m n o p q r s t u v w x y z A B C D E F G H I J K L M N O P Q R S T U V W X Y Z} + +if $atBerkeley { + test format-9.1 {"h" format specifier} { + format %hd 0xffff + } -1 + test format-9.2 {"h" format specifier} { + format %hx 0x10fff + } fff + test format-9.3 {"h" format specifier} { + format %hd 0x10000 + } 0 +} + +test format-10.1 {XPG3 %$n specifiers} { + format {%2$d %1$d} 4 5 +} {5 4} +test format-10.2 {XPG3 %$n specifiers} { + format {%2$d %1$d %1$d %3$d} 4 5 6 +} {5 4 4 6} +test format-10.3 {XPG3 %$n specifiers} { + list [catch {format {%2$d %3$d} 4 5} msg] $msg +} {1 {"%n$" argument index out of range}} +test format-10.4 {XPG3 %$n specifiers} { + list [catch {format {%2$d %0$d} 4 5 6} msg] $msg +} {1 {"%n$" argument index out of range}} +test format-10.5 {XPG3 %$n specifiers} { + list [catch {format {%d %1$d} 4 5 6} msg] $msg +} {1 {cannot mix "%" and "%n$" conversion specifiers}} +test format-10.6 {XPG3 %$n specifiers} { + list [catch {format {%2$d %d} 4 5 6} msg] $msg +} {1 {cannot mix "%" and "%n$" conversion specifiers}} +test format-10.7 {XPG3 %$n specifiers} { + list [catch {format {%2$d %3d} 4 5 6} msg] $msg +} {1 {cannot mix "%" and "%n$" conversion specifiers}} +test format-10.8 {XPG3 %$n specifiers} { + format {%2$*d %3$d} 1 10 4 +} { 4 4} +test format-10.9 {XPG3 %$n specifiers} { + format {%2$.*s %4$d} 1 5 abcdefghijklmnop 44 +} {abcde 44} +test format-10.10 {XPG3 %$n specifiers} { + list [catch {format {%2$*d} 4} msg] $msg +} {1 {"%n$" argument index out of range}} +test format-10.11 {XPG3 %$n specifiers} { + list [catch {format {%2$*d} 4 5} msg] $msg +} {1 {"%n$" argument index out of range}} +test format-10.12 {XPG3 %$n specifiers} { + list [catch {format {%2$*d} 4 5 6} msg] $msg +} {0 { 6}} diff --git a/vendor/x11iraf/obm/Tcl/tests/glob.test b/vendor/x11iraf/obm/Tcl/tests/glob.test new file mode 100644 index 00000000..ba134ed8 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/tests/glob.test @@ -0,0 +1,153 @@ +# Commands covered: glob +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1991-1993 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. +# +# $Header: /user6/ouster/tcl/tests/RCS/glob.test,v 1.23 93/08/28 15:57:40 ouster Exp $ (Berkeley) + +if {[string compare test [info procs test]] == 1} then {source defs} + +# First, create some subdirectories to use for testing. + +exec rm -rf globTest +exec mkdir globTest globTest/a1 globTest/a2 globTest/a3 +exec mkdir globTest/a1/b1 globTest/a1/b2 globTest/a2/b3 +exec cat << abc > globTest/x1.c +exec cat << abc > globTest/y1.c +exec cat << abc > globTest/z1.c +exec cat << abc > "globTest/weird name.c" +exec cat << abc > globTest/.1 +exec cat << abc > globTest/a1/b1/x2.c +exec cat << abc > globTest/a1/b2/y2.c + +test glob-1.1 {simple globbing} { + lsort [glob globTest/x1.c globTest/y1.c globTest/foo] +} {globTest/x1.c globTest/y1.c} +test glob-1.2 {simple globbing} { + glob {} +} . + +test glob-2.1 {globbing with braces} { + glob -nocomplain "{a1,a2}" +} {} +test glob-2.2 {globbing with braces} { + lsort [glob globTest/{a,b,x,y}1.c] +} {globTest/x1.c globTest/y1.c} +test glob-2.3 {globbing with braces} { + lsort [glob {globTest/{x1,y2,weird name}.c}] +} {{globTest/weird name.c} globTest/x1.c} +test glob-2.4 {globbing with braces} { + lsort [glob globTest/{x1.c,a1/*}] +} {globTest/a1/b1 globTest/a1/b2 globTest/x1.c} + +test glob-3.1 {asterisks, question marks, and brackets} { + lsort [glob g*/*.c] +} {{globTest/weird name.c} globTest/x1.c globTest/y1.c globTest/z1.c} +test glob-3.2 {asterisks, question marks, and brackets} { + lsort [glob globTest/?1.c] +} {globTest/x1.c globTest/y1.c globTest/z1.c} +test glob-3.3 {asterisks, question marks, and brackets} { + lsort [glob */*/*/*.c] +} {globTest/a1/b1/x2.c globTest/a1/b2/y2.c} +test glob-3.4 {asterisks, question marks, and brackets} { + lsort [glob globTest/*] +} {globTest/a1 globTest/a2 globTest/a3 {globTest/weird name.c} globTest/x1.c globTest/y1.c globTest/z1.c} +test glob-3.5 {asterisks, question marks, and brackets} { + lsort [glob globTest/.*] +} {globTest/. globTest/.. globTest/.1} +test glob-3.6 {asterisks, question marks, and brackets} { + lsort [glob globTest/*/*] +} {globTest/a1/b1 globTest/a1/b2 globTest/a2/b3} +test glob-3.7 {asterisks, question marks, and brackets} { + lsort [glob {globTest/[xyab]1.*}] +} {globTest/x1.c globTest/y1.c} +test glob-3.8 {asterisks, question marks, and brackets} { + lsort [glob globTest/*/] +} {globTest/a1/ globTest/a2/ globTest/a3/} + +# The tests immediately below can only be run at Berkeley, where +# the file-system structure is well-known. + +if $atBerkeley { + test glob-4.1 {tildes} {glob ~/.csh*} "/users/ouster/.cshrc" + test glob-4.2 {tildes} {glob ~ouster/.csh*} "/users/ouster/.cshrc" +} + +test glob-5.1 {error conditions} { + list [catch {glob} msg] $msg +} {1 {wrong # args: should be "glob ?switches? name ?name ...?"}} +test glob-5.2 {error conditions} { + list [catch {glob globTest/\{} msg] $msg +} {1 {unmatched open-brace in file name}} +test glob-5.3 {error conditions} { + list [catch {glob globTest/*/gorp} msg] $msg +} {1 {no files matched glob pattern "globTest/*/gorp"}} +test glob-5.4 {error conditions} { + list [catch {glob goo/* x*z foo?q} msg] $msg +} {1 {no files matched glob patterns "goo/* x*z foo?q"}} +test glob-5.5 {error conditions} { + list [catch {lsort [glob globTest/*.c goo/*]} msg] $msg +} {0 {{globTest/weird name.c} globTest/x1.c globTest/y1.c globTest/z1.c}} +test glob-5.6 {error conditions} { + list [catch {glob ~no-one} msg] $msg +} {1 {user "no-one" doesn't exist}} +test glob-5.7 {error conditions} { + set home $env(HOME) + unset env(HOME) + set x [list [catch {glob ~/*} msg] $msg] + set env(HOME) $home + set x +} {1 {couldn't find HOME environment variable to expand "~/*"}} +test glob-5.8 {error conditions} { + list [catch {glob globTest/{a1,a2}/\{} msg] $msg +} {1 {unmatched open-brace in file name}} +test glob-5.9 {error conditions} { + list [catch {glob globTest/*/\{} msg] $msg +} {1 {unmatched open-brace in file name}} + +exec chmod 000 globTest +if {$user != "root"} { + test glob-6.1 {setting errorCode variable} { + string tolower [list [catch {glob globTest/*} msg] $msg $errorCode] + } {1 {couldn't read directory "globtest": permission denied} {posix eacces {permission denied}}} +} +exec chmod 755 globTest + +test glob-7.1 {-nocomplain switch} { + list [catch {glob -nocomplai} msg] $msg +} {1 {bad switch "-nocomplai": must be -nocomplain or --}} +test glob-7.2 {-nocomplain switch} { + list [catch {glob -nocomplain} msg] $msg +} {1 {wrong # args: should be "glob ?switches? name ?name ...?"}} +test glob-7.3 {-nocomplain switch} { + list [catch {glob -nocomplain goo/*} msg] $msg +} {0 {}} +test glob-7.4 {-- switch} { + list [catch {glob -- -nocomplain} msg] $msg +} {1 {no files matched glob patterns "-nocomplain"}} +test glob-7.5 {bogus switch} { + list [catch {glob -gorp} msg] $msg +} {1 {bad switch "-gorp": must be -nocomplain or --}} + +exec rm -rf globTest diff --git a/vendor/x11iraf/obm/Tcl/tests/history.test b/vendor/x11iraf/obm/Tcl/tests/history.test new file mode 100644 index 00000000..56e337be --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/tests/history.test @@ -0,0 +1,400 @@ +# Commands covered: history +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1991-1993 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. +# +# $Header: /user6/ouster/tcl/tests/RCS/history.test,v 1.8 93/02/06 15:53:54 ouster Exp $ (Berkeley) + +if {[info commands history] == ""} { + puts stdout "This version of Tcl was built without the history command;\n" + puts stdout "history tests will be skipped.\n" + return +} + +if {[string compare test [info procs test]] == 1} then {source defs} + +set num [history nextid] +history keep 3 +history add {set a 12345} +history add {set b [format {A test %s} string]} +history add {Another test} + +# "history event" + +test history-1.1 {event option} {history event -1} \ + {set b [format {A test %s} string]} +test history-1.2 {event option} {history event $num} \ + {set a 12345} +test history-1.3 {event option} {history event [expr $num+2]} \ + {Another test} +test history-1.4 {event option} {history event set} \ + {set b [format {A test %s} string]} +test history-1.5 {event option} {history e "* a*"} \ + {set a 12345} +test history-1.6 {event option} {catch {history event *gorp} msg} 1 +test history-1.7 {event option} { + catch {history event *gorp} msg + set msg +} {no event matches "*gorp"} +test history-1.8 {event option} {history event} \ + {set b [format {A test %s} string]} +test history-1.9 {event option} {catch {history event 123 456} msg} 1 +test history-1.10 {event option} { + catch {history event 123 456} msg + set msg +} {wrong # args: should be "history event ?event?"} + +# "history redo" + +set a 0 +history redo -2 +test history-2.1 {redo option} {set a} 12345 +set b 0 +history redo +test history-2.2 {redo option} {set b} {A test string} +test history-2.3 {redo option} {catch {history redo -3 -4}} 1 +test history-2.4 {redo option} { + catch {history redo -3 -4} msg + set msg +} {wrong # args: should be "history redo ?event?"} + +# "history add" + +history add "set a 444" exec +test history-3.1 {add option} {set a} 444 +test history-3.2 {add option} {catch {history add "set a 444" execGorp}} 1 +test history-3.3 {add option} { + catch {history add "set a 444" execGorp} msg + set msg +} {bad argument "execGorp": should be "exec"} +test history-3.4 {add option} {catch {history add "set a 444" a} msg} 1 +test history-3.5 {add option} { + catch {history add "set a 444" a} msg + set msg +} {bad argument "a": should be "exec"} +history add "set a 555" e +test history-3.6 {add option} {set a} 555 +history add "set a 666" +test history-3.7 {add option} {set a} 555 +test history-3.8 {add option} {catch {history add "set a 666" e f} msg} 1 +test history-3.9 {add option} { + catch {history add "set a 666" e f} msg + set msg +} {wrong # args: should be "history add event ?exec?"} + +# "history change" + +history change "A test value" +test history-4.1 {change option} {history event [expr {[history n]-1}]} \ + "A test value" +history c "Another test" -1 +test history-4.2 {change option} {history e} "Another test" +test history-4.3 {change option} {history event [expr {[history n]-1}]} \ + "A test value" +test history-4.4 {change option} {catch {history change Foo 4 10}} 1 +test history-4.5 {change option} { + catch {history change Foo 4 10} msg + set msg +} {wrong # args: should be "history change newValue ?event?"} +test history-4.6 {change option} { + catch {history change Foo [expr {[history n]-4}]} +} 1 +test history-4.7 {change option} { + catch {history change Foo [expr {[history n]-4}]} + set msg +} {wrong # args: should be "history change newValue ?event?"} + +# "history info" + +set num [history n] +history add set\ a\ {b\nc\ d\ e} +history add {set b 1234} +history add set\ c\ {a\nb\nc} +test history-5.1 {info option} {history info} [format {%6d set a {b + c d e} +%6d set b 1234 +%6d set c {a + b + c}} $num [expr $num+1] [expr $num+2]] +test history-5.2 {info option} {history i 2} [format {%6d set b 1234 +%6d set c {a + b + c}} [expr $num+1] [expr $num+2]] +test history-5.3 {info option} {catch {history i 2 3}} 1 +test history-5.4 {info option} { + catch {history i 2 3} msg + set msg +} {wrong # args: should be "history info ?count?"} +test history-5.5 {info option} {history} [format {%6d set a {b + c d e} +%6d set b 1234 +%6d set c {a + b + c}} $num [expr $num+1] [expr $num+2]] + +# "history keep" + +history add "foo1" +history add "foo2" +history add "foo3" +history keep 2 +test history-6.1 {keep option} {history event [expr [history n]-1]} foo3 +test history-6.2 {keep option} {history event -1} foo2 +test history-6.3 {keep option} {catch {history event -3}} 1 +test history-6.4 {keep option} { + catch {history event -3} msg + set msg +} {event "-3" is too far in the past} +history k 5 +test history-6.5 {keep option} {history event -1} foo2 +test history-6.6 {keep option} {history event -2} {} +test history-6.7 {keep option} {history event -3} {} +test history-6.8 {keep option} {history event -4} {} +test history-6.9 {keep option} {catch {history event -5}} 1 +test history-6.10 {keep option} {catch {history keep 4 6}} 1 +test history-6.11 {keep option} { + catch {history keep 4 6} msg + set msg +} {wrong # args: should be "history keep number"} +test history-6.12 {keep option} {catch {history keep}} 1 +test history-6.13 {keep option} { + catch {history keep} msg + set msg +} {wrong # args: should be "history keep number"} +test history-6.14 {keep option} {catch {history keep -3}} 1 +test history-6.15 {keep option} { + catch {history keep -3} msg + set msg +} {illegal keep count "-3"} + +# "history nextid" + +set num [history n] +history add "Testing" +history add "Testing2" +test history-7.1 {nextid option} {history event} "Testing" +test history-7.2 {nextid option} {history next} [expr $num+2] +test history-7.3 {nextid option} {catch {history nextid garbage}} 1 +test history-7.4 {nextid option} { + catch {history nextid garbage} msg + set msg +} {wrong # args: should be "history nextid"} + +# "history substitute" + +test history-8.1 {substitute option} { + history add "set a {test foo test b c test}" + history add "Test command 2" + set a 0 + history substitute foo bar -1 + set a +} {test bar test b c test} +test history-8.2 {substitute option} { + history add "set a {test foo test b c test}" + history add "Test command 2" + set a 0 + history substitute test gorp + set a +} {gorp foo gorp b c gorp} +test history-8.3 {substitute option} { + history add "set a {test foo test b c test}" + history add "Test command 2" + set a 0 + history sub " te" to + set a +} {test footost b ctost} +test history-8.4 {substitute option} {catch {history sub xxx yyy}} 1 +test history-8.5 {substitute option} { + catch {history sub xxx yyy} msg + set msg +} {"xxx" doesn't appear in event} +test history-8.6 {substitute option} {catch {history s a b -10}} 1 +test history-8.7 {substitute option} { + catch {history s a b -10} msg + set msg +} {event "-10" is too far in the past} +test history-8.8 {substitute option} {catch {history s a b -1 20}} 1 +test history-8.9 {substitute option} { + catch {history s a b -1 20} msg + set msg +} {wrong # args: should be "history substitute old new ?event?"} + +# "history words" + +test history-9.1 {words option} { + history add {word0 word1 word2 a b c word6} + history add foo + history words 0-$ +} {word0 word1 word2 a b c word6} +test history-9.2 {words option} { + history add {word0 word1 word2 a b c word6} + history add foo + history w 2 -1 +} word2 +test history-9.3 {words option} { + history add {word0 word1 word2 a b c word6} + history add foo + history wo $ +} word6 +test history-9.4 {words option} {catch {history w 1--1} msg} 1 +test history-9.5 {words option} { + catch {history w 1--1} msg + set msg +} {bad word selector "1--1": should be num-num or pattern} +test history-9.6 {words option} { + history add {word0 word1 word2 a b c word6} + history add foo + history w w +} {} +test history-9.7 {words option} { + history add {word0 word1 word2 a b c word6} + history add foo + history w *2 +} word2 +test history-9.8 {words option} { + history add {word0 word1 word2 a b c word6} + history add foo + history w *or* +} {word0 word1 word2 word6} +test history-9.9 {words option} {catch {history words 10}} 1 +test history-9.10 {words option} { + catch {history words 10} msg + set msg +} {word selector "10" specified non-existent words} +test history-9.11 {words option} {catch {history words 1 -1 20}} 1 +test history-9.12 {words option} { + catch {history words 1 -1 20} msg + set msg +} {wrong # args: should be "history words num-num/pat ?event?"} + +# history revision + +test history-10.1 {history revision} { + set a 0 + history a {set a 12345} + history a {set a [history e]} exec + set a +} {set a 12345} +test history-10.2 {history revision} { + set a 0 + history a {set a 12345} + history a {set a [history e]} exec + history a foo + history ev -1 +} {set a {set a 12345}} +test history-10.3 {history revision} { + set a 0 + history a {set a 12345} + history a {set a [history e]} exec + history a foo + history a {history r -2} exec + history a {set a 12345} + history ev -1 +} {set a {set a 12345}} +test history-10.4 {history revision} { + history a {set a 12345} + history a {history s 123 999} exec + history a foo + history ev -1 +} {set a 99945} +test history-10.5 {history revision} { + history add {word0 word1 word2 a b c word6} + history add {set [history w 3] [list [history w 0] [history w {[ab]}]]} exec + set a +} {word0 {a b}} +test history-10.6 {history revision} { + history add {word0 word1 word2 a b c word6} + history add {set [history w 3] [list [history w 0] [history w {[ab]}]]} exec + history add foo + history ev +} {set a [list word0 {a b}]} +test history-10.7 {history revision} { + history add {word0 word1 word2 a b c word6} + history add {set [history w 3] [list [history w 0] [history w {[ab]}]]} exec + history add {format b} + history add {word0 word1 word2 a b c word6} + set a 0 + history add {set [history subs b a -2] [list abc [history r -2] [history w 1-3]]} exec + history add foo + history ev +} {set [format a] [list abc [format b] {word1 word2 a}]} +test history-10.8 {history revision} { + history add {set a 12345} + concat a b c + history add {history redo; set b 44} exec + history add foo + history ev +} {set a 12345; set b 44} +test history-10.9 {history revision} { + history add {set a 12345} + history add {history redo; history change "A simple test"; history subs 45 xx} exec + set a +} 123xx +test history-10.10 {history revision} { + history add {set a 12345} + history add {history redo; history change "A simple test"; history subs 45 xx} exec + history add foo + history e +} {A simple test} +test history-10.11 {history revision} { + history add {word0 word1 $ a b c word6} + history add {set a [history w 4-[history word 2]]} exec + set a +} {b c word6} +test history-10.12 {history revision} { + history add {word0 word1 $ a b c word6} + history add {set a [history w 4-[history word 2]]} exec + history add foo + history e +} {set a {b c word6}} +test history-10.13 {history revision} { + history add {history word 0} exec + history add foo + history e +} {history word 0} +test history-10.14 {history revision} { + history add {set a [history word 0; format c]} exec + history add foo + history e +} {set a [history word 0; format c]} +test history-10.15 {history revision even when nested} { + proc x {a b} {history word $a $b} + history add {word1 word2 word3 word4} + history add {set a [x 1-3 -1]} exec + history add foo + history e +} {set a {word2 word3 word4}} +test history-10.16 {disable history revision in nested history evals} { + history add {word1 word2 word3 word4} + history add {set a [history words 0]; history add foo; set a [history words 0]} exec + history e +} {set a word1; history add foo; set a [history words 0]} + +# miscellaneous + +test history-11.1 {miscellaneous} {catch {history gorp} msg} 1 +test history-11.2 {miscellaneous} { + catch {history gorp} msg + set msg +} {bad option "gorp": must be add, change, event, info, keep, nextid, redo, substitute, or words} diff --git a/vendor/x11iraf/obm/Tcl/tests/if.test b/vendor/x11iraf/obm/Tcl/tests/if.test new file mode 100644 index 00000000..1ab205ed --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/tests/if.test @@ -0,0 +1,162 @@ +# Commands covered: if +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1991-1993 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. +# +# $Header: /user6/ouster/tcl/tests/RCS/if.test,v 1.5 93/02/06 15:54:17 ouster Exp $ (Berkeley) + +if {[string compare test [info procs test]] == 1} then {source defs} + +test if-1.1 {taking proper branch} { + set a {} + if 0 {set a 1} else {set a 2} + set a +} 2 +test if-1.2 {taking proper branch} { + set a {} + if 1 {set a 1} else {set a 2} + set a +} 1 +test if-1.3 {taking proper branch} { + set a {} + if 1<2 {set a 1} + set a +} 1 +test if-1.4 {taking proper branch} { + set a {} + if 1>2 {set a 1} + set a +} {} +test if-1.5 {taking proper branch} { + set a {} + if 0 {set a 1} else {} + set a +} {} +test if-1.5 {taking proper branch} { + set a {} + if 0 {set a 1} elseif 1 {set a 2} elseif 1 {set a 3} else {set a 4} + set a +} {2} +test if-1.6 {taking proper branch} { + set a {} + if 0 {set a 1} elseif 0 {set a 2} elseif 1 {set a 3} else {set a 4} + set a +} {3} +test if-1.7 {taking proper branch} { + set a {} + if 0 {set a 1} elseif 0 {set a 2} elseif 0 {set a 3} else {set a 4} + set a +} {4} + + +test if-2.1 {optional then-else args} { + set a 44 + if 0 then {set a 1} elseif 0 then {set a 3} else {set a 2} + set a +} 2 +test if-2.2 {optional then-else args} { + set a 44 + if 1 then {set a 1} else {set a 2} + set a +} 1 +test if-2.3 {optional then-else args} { + set a 44 + if 0 {set a 1} else {set a 2} + set a +} 2 +test if-2.4 {optional then-else args} { + set a 44 + if 1 {set a 1} else {set a 2} + set a +} 1 +test if-2.5 {optional then-else args} { + set a 44 + if 0 then {set a 1} {set a 2} + set a +} 2 +test if-2.6 {optional then-else args} { + set a 44 + if 1 then {set a 1} {set a 2} + set a +} 1 +test if-2.7 {optional then-else args} { + set a 44 + if 0 then {set a 1} else {set a 2} + set a +} 2 +test if-2.8 {optional then-else args} { + set a 44 + if 0 then {set a 1} elseif 0 {set a 2} elseif 0 {set a 3} {set a 4} + set a +} 4 + +test if-3.1 {return value} { + if 1 then {set a 22; concat abc} +} abc +test if-3.2 {return value} { + if 0 then {set a 22; concat abc} elseif 1 {concat def} {concat ghi} +} def +test if-3.3 {return value} { + if 0 then {set a 22; concat abc} else {concat def} +} def +test if-3.4 {return value} { + if 0 then {set a 22; concat abc} +} {} +test if-3.5 {return value} { + if 0 then {set a 22; concat abc} elseif 0 {concat def} +} {} + +test if-4.1 {error conditions} { + list [catch {if} msg] $msg +} {1 {wrong # args: no expression after "if" argument}} +test if-4.2 {error conditions} { + list [catch {if {[error "error in condition"]}} msg] $msg +} {1 {error in condition}} +test if-4.3 {error conditions} { + list [catch {if 2} msg] $msg +} {1 {wrong # args: no script following "2" argument}} +test if-4.4 {error conditions} { + list [catch {if 2 then} msg] $msg +} {1 {wrong # args: no script following "then" argument}} +test if-4.5 {error conditions} { + list [catch {if 2 the} msg] $msg +} {1 {invalid command name: "the"}} +test if-4.6 {error conditions} { + list [catch {if 2 then {[error "error in then clause"]}} msg] $msg +} {1 {error in then clause}} +test if-4.7 {error conditions} { + list [catch {if 0 then foo elseif} msg] $msg +} {1 {wrong # args: no expression after "elseif" argument}} +test if-4.8 {error conditions} { + list [catch {if 0 then foo elsei} msg] $msg +} {1 {invalid command name: "elsei"}} +test if-4.9 {error conditions} { + list [catch {if 0 then foo elseif 0 bar else} msg] $msg +} {1 {wrong # args: no script following "else" argument}} +test if-4.10 {error conditions} { + list [catch {if 0 then foo elseif 0 bar els} msg] $msg +} {1 {invalid command name: "els"}} +test if-4.11 {error conditions} { + list [catch {if 0 then foo elseif 0 bar else {[error "error in else clause"]}} msg] $msg +} {1 {error in else clause}} diff --git a/vendor/x11iraf/obm/Tcl/tests/incr.test b/vendor/x11iraf/obm/Tcl/tests/incr.test new file mode 100644 index 00000000..d04fe7f6 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/tests/incr.test @@ -0,0 +1,86 @@ +# Commands covered: lreplace +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1991-1993 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. +# +# $Header: /user6/ouster/tcl/tests/RCS/incr.test,v 1.5 93/07/12 11:34:43 ouster Exp $ (Berkeley) + +if {[string compare test [info procs test]] == 1} then {source defs} + +catch {unset x} + +test incr-1.1 {basic incr operation} { + set x 23 + list [incr x] $x +} {24 24} +test incr-1.2 {basic incr operation} { + set x 106 + list [incr x -5] $x +} {101 101} +test incr-1.3 {basic incr operation} { + set x " -106" + list [incr x 1] $x +} {-105 -105} +test incr-1.3 {basic incr operation} { + set x " +106" + list [incr x 1] $x +} {107 107} + +test incr-2.1 {incr errors} { + list [catch incr msg] $msg +} {1 {wrong # args: should be "incr varName ?increment?"}} +test incr-2.2 {incr errors} { + list [catch {incr a b c} msg] $msg +} {1 {wrong # args: should be "incr varName ?increment?"}} +test incr-2.3 {incr errors} { + catch {unset x} + list [catch {incr x} msg] $msg $errorInfo +} {1 {can't read "x": no such variable} {can't read "x": no such variable + while executing +"incr x"}} +test incr-2.4 {incr errors} { + set x abc + list [catch {incr x} msg] $msg $errorInfo +} {1 {expected integer but got "abc"} {expected integer but got "abc" + (reading value of variable to increment) + invoked from within +"incr x"}} +test incr-2.5 {incr errors} { + set x 123 + list [catch {incr x 1a} msg] $msg $errorInfo +} {1 {expected integer but got "1a"} {expected integer but got "1a" + (reading increment) + invoked from within +"incr x 1a"}} +test incr-2.6 {incr errors} { + proc readonly args {error "variable is read-only"} + set x 123 + trace var x w readonly + list [catch {incr x 1} msg] $msg $errorInfo +} {1 {can't set "x": variable is read-only} {can't set "x": variable is read-only + while executing +"incr x 1"}} + +catch {unset x} +concat {} diff --git a/vendor/x11iraf/obm/Tcl/tests/info.test b/vendor/x11iraf/obm/Tcl/tests/info.test new file mode 100644 index 00000000..ecc7d940 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/tests/info.test @@ -0,0 +1,524 @@ +# Commands covered: info +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1991-1993 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. +# +# $Header: /user6/ouster/tcl/tests/RCS/info.test,v 1.17 93/10/13 13:02:02 ouster Exp $ (Berkeley) + +if {[string compare test [info procs test]] == 1} then {source defs} + +test info-1.1 {info args option} { + proc t1 {a bbb c} {return foo} + info args t1 +} {a bbb c} +test info-1.2 {info args option} { + proc t1 {{a default1} {bbb default2} {c default3} args} {return foo} + info a t1 +} {a bbb c args} +test info-1.3 {info args option} { + proc t1 "" {return foo} + info args t1 +} {} +test info-1.4 {info args option} { + catch {rename t1 {}} + list [catch {info args t1} msg] $msg +} {1 {"t1" isn't a procedure}} +test info-1.5 {info args option} { + list [catch {info args set} msg] $msg +} {1 {"set" isn't a procedure}} + +test info-2.1 {info body option} { + proc t1 {} {body of t1} + info body t1 +} {body of t1} +test info-2.2 {info body option} { + list [catch {info body set} msg] $msg +} {1 {"set" isn't a procedure}} +test info-2.3 {info body option} { + list [catch {info args set 1} msg] $msg +} {1 {wrong # args: should be "info args procname"}} + +test info-3.1 {info cmdcount option} { + set x [info cmdcount] + set y 12345 + set z [info cm] + expr $z-$x +} 3 +test info-3.2 {info body option} { + list [catch {info cmdcount 1} msg] $msg +} {1 {wrong # args: should be "info cmdcount"}} + +test info-4.1 {info commands option} { + proc t1 {} {} + proc t2 {} {} + set x " [info commands] " + list [string match {* t1 *} $x] [string match {* t2 *} $x] \ + [string match {* set *} $x] [string match {* list *} $x] +} {1 1 1 1} +test info-4.2 {info commands option} { + proc t1 {} {} + rename t1 {} + set x [info comm] + string match {* t1 *} $x +} 0 +test info-4.3 {info commands option} { + proc _t1_ {} {} + proc _t2_ {} {} + info commands _t1_ +} _t1_ +test info-4.4 {info commands option} { + proc _t1_ {} {} + proc _t2_ {} {} + lsort [info commands _t*] +} {_t1_ _t2_} +catch {rename _t1_ {}} +catch {rename _t2_ {}} +test info-4.5 {info commands option} { + list [catch {info commands a b} msg] $msg +} {1 {wrong # args: should be "info commands [pattern]"}} + +test info-5.1 {info complete option} { + info complete "" +} 1 +test info-5.2 {info complete option} { + info complete " \n" +} 1 +test info-5.3 {info complete option} { + info complete "abc def" +} 1 +test info-5.4 {info complete option} { + info complete "a b c d e f \t\n" +} 1 +test info-5.5 {info complete option} { + info complete {a b c"d} +} 1 +test info-5.6 {info complete option} { + info complete {a b "c d" e} +} 1 +test info-5.7 {info complete option} { + info complete {a b "c d"} +} 1 +test info-5.8 {info complete option} { + info complete {a b "c d"} +} 1 +test info-5.9 {info complete option} { + info complete {a b "c d} +} 0 +test info-5.10 {info complete option} { + info complete {a b "} +} 0 +test info-5.11 {info complete option} { + info complete {a b "cd"xyz} +} 1 +test info-5.12 {info complete option} { + info complete {a b "c $d() d"} +} 1 +test info-5.13 {info complete option} { + info complete {a b "c $dd("} +} 0 +test info-5.14 {info complete option} { + info complete {a b "c \"} +} 0 +test info-5.15 {info complete option} { + info complete {a b "c [d e f]"} +} 1 +test info-5.16 {info complete option} { + info complete {a b "c [d e f] g"} +} 1 +test info-5.17 {info complete option} { + info complete {a b "c [d e f"} +} 0 +test info-5.18 {info complete option} { + info complete {a {b c d} e} +} 1 +test info-5.19 {info complete option} { + info complete {a {b c d}} +} 1 +test info-5.20 {info complete option} { + info complete "a b\{c d" +} 1 +test info-5.21 {info complete option} { + info complete "a b \{c" +} 0 +test info-5.22 {info complete option} { + info complete "a b \{c{ }" +} 0 +test info-5.23 {info complete option} { + info complete "a b {c d e}xxx" +} 1 +test info-5.24 {info complete option} { + info complete "a b {c \\\{d e}xxx" +} 1 +test info-5.25 {info complete option} { + info complete {a b [ab cd ef]} +} 1 +test info-5.26 {info complete option} { + info complete {a b x[ab][cd][ef] gh} +} 1 +test info-5.27 {info complete option} { + info complete {a b x[ab][cd[ef] gh} +} 0 +test info-5.28 {info complete option} { + info complete {a b x[ gh} +} 0 +test info-5.29 {info complete option} { + info complete {[]]]} +} 1 +test info-5.30 {info complete option} { + info complete {abc x$yyy} +} 1 +test info-5.31 {info complete option} { + info complete "abc x\${abc\[\\d} xyz" +} 1 +test info-5.32 {info complete option} { + info complete "abc x\$\{ xyz" +} 0 +test info-5.33 {info complete option} { + info complete {word $a(xyz)} +} 1 +test info-5.34 {info complete option} { + info complete {word $a(} +} 0 +test info-5.35 {info complete option} { + info complete "set a \\\n" +} 0 +test info-5.36 {info complete option} { + info complete "set a \\n " +} 1 +test info-5.37 {info complete option} { + info complete "set a \\" +} 1 +test info-5.38 {info complete option} { + info complete "foo \\\n\{" +} 0 +test info-5.39 {info complete option} { + info complete " # \{" +} 1 +test info-5.40 {info complete option} { + info complete "foo bar;# \{" +} 1 +test info-5.41 {info complete option} { + info complete "a\nb\n# \{\n# \{\nc\n" +} 1 + +test info-6.1 {info default option} { + proc t1 {a b {c d} {e "long default value"}} {} + info default t1 a value +} 0 +test info-6.2 {info default option} { + proc t1 {a b {c d} {e "long default value"}} {} + set value 12345 + info d t1 a value + set value +} {} +test info-6.3 {info default option} { + proc t1 {a b {c d} {e "long default value"}} {} + info default t1 c value +} 1 +test info-6.4 {info default option} { + proc t1 {a b {c d} {e "long default value"}} {} + set value 12345 + info default t1 c value + set value +} d +test info-6.5 {info default option} { + proc t1 {a b {c d} {e "long default value"}} {} + set value 12345 + set x [info default t1 e value] + list $x $value +} {1 {long default value}} +test info-6.6 {info default option} { + list [catch {info default a b} msg] $msg +} {1 {wrong # args: should be "info default procname arg varname"}} +test info-6.7 {info default option} { + list [catch {info default _nonexistent_ a b} msg] $msg +} {1 {"_nonexistent_" isn't a procedure}} +test info-6.8 {info default option} { + proc t1 {a b} {} + list [catch {info default t1 x value} msg] $msg +} {1 {procedure "t1" doesn't have an argument "x"}} +test info-6.9 {info default option} { + catch {unset a} + set a(0) 88 + proc t1 {a b} {} + list [catch {info default t1 a a} msg] $msg +} {1 {couldn't store default value in variable "a"}} +test info-6.10 {info default option} { + catch {unset a} + set a(0) 88 + proc t1 {{a 18} b} {} + list [catch {info default t1 a a} msg] $msg +} {1 {couldn't store default value in variable "a"}} +catch {unset a} + +test info-7.1 {info exists option} { + set value foo + info exists value +} 1 +catch {unset _nonexistent_} +test info-7.2 {info exists option} { + info exists _nonexistent_ +} 0 +test info-7.3 {info exists option} { + proc t1 {x} {return [info exists x]} + t1 2 +} 1 +test info-7.4 {info exists option} { + proc t1 {x} { + global _nonexistent_ + return [info exists _nonexistent_] + } + t1 2 +} 0 +test info-7.5 {info exists option} { + proc t1 {x} { + set y 47 + return [info exists y] + } + t1 2 +} 1 +test info-7.6 {info exists option} { + proc t1 {x} {return [info exists value]} + t1 2 +} 0 +test info-7.7 {info exists option} { + catch {unset x} + set x(2) 44 + list [info exists x] [info exists x(1)] [info exists x(2)] +} {1 0 1} +catch {unset x} +test info-7.8 {info exists option} { + list [catch {info exists} msg] $msg +} {1 {wrong # args: should be "info exists varName"}} +test info-7.9 {info exists option} { + list [catch {info exists 1 2} msg] $msg +} {1 {wrong # args: should be "info exists varName"}} + +test info-8.1 {info globals option} { + set x 1 + set y 2 + set value 23 + set a " [info globals] " + list [string match {* x *} $a] [string match {* y *} $a] \ + [string match {* value *} $a] [string match {* _foobar_ *} $a] +} {1 1 1 0} +test info-8.2 {info globals option} { + set _xxx1 1 + set _xxx2 2 + lsort [info g _xxx*] +} {_xxx1 _xxx2} +test info-8.3 {info globals option} { + list [catch {info globals 1 2} msg] $msg +} {1 {wrong # args: should be "info globals [pattern]"}} + +test info-9.1 {info level option} { + info level +} 0 +test info-9.2 {info level option} { + proc t1 {a b} { + set x [info le] + set y [info level 1] + list $x $y + } + t1 146 testString +} {1 {t1 146 testString}} +test info-9.3 {info level option} { + proc t1 {a b} { + t2 [expr $a*2] $b + } + proc t2 {x y} { + list [info level] [info level 1] [info level 2] [info level -1] \ + [info level 0] + } + t1 146 {a {b c} {{{c}}}} +} {2 {t1 146 {a {b c} {{{c}}}}} {t2 292 {a {b c} {{{c}}}}} {t1 146 {a {b c} {{{c}}}}} {t2 292 {a {b c} {{{c}}}}}} +test info-9.4 {info level option} { + proc t1 {} { + set x [info level] + set y [info level 1] + list $x $y + } + t1 +} {1 t1} +test info-9.5 {info level option} { + list [catch {info level 1 2} msg] $msg +} {1 {wrong # args: should be "info level [number]"}} +test info-9.6 {info level option} { + list [catch {info level 123a} msg] $msg +} {1 {expected integer but got "123a"}} +test info-9.7 {info level option} { + list [catch {info level 0} msg] $msg +} {1 {bad level "0"}} +test info-9.8 {info level option} { + proc t1 {} {info level -1} + list [catch {t1} msg] $msg +} {1 {bad level "-1"}} +test info-9.9 {info level option} { + proc t1 {x} {info level $x} + list [catch {t1 -3} msg] $msg +} {1 {bad level "-3"}} + +test info-10.1 {info library option} { + list [catch {info library x} msg] $msg +} {1 {wrong # args: should be "info library"}} +# The following check can only be done at Berkeley, where the exact +# location of the library is known. + +if $atBerkeley { + test info-10.2 {info library option} { + info li + } /users/ouster/tcl/library + test info-10.3 {info library option} { + set env(TCL_LIBRARY) test_value + set result [info library] + unset env(TCL_LIBRARY) + list $result [info library] + } {test_value /users/ouster/tcl/library} +} + +test info-11.1 {info locals option} { + set a 22 + proc t1 {x y} { + set b 13 + set c testing + global a + return [info locals] + } + lsort [t1 23 24] +} {b c x y} +test info-11.2 {info locals option} { + proc t1 {x y} { + set xx1 2 + set xx2 3 + set y 4 + return [info lo x*] + } + lsort [t1 2 3] +} {x xx1 xx2} +test info-11.3 {info locals option} { + list [catch {info locals 1 2} msg] $msg +} {1 {wrong # args: should be "info locals [pattern]"}} +test info-11.4 {info locals option} { + info locals +} {} +test info-11.5 {info locals option} { + proc t1 {} {return [info locals]} + t1 +} {} + +test info-12.1 {info patchlevel option} { + set a [info patchlevel] + incr a 2 + expr $a-[info patchlevel] +} 2 +test info-12.2 {info patchlevel option} { + list [catch {info patchlevel a} msg] $msg +} {1 {wrong # args: should be "info patchlevel"}} + +test info-13.1 {info procs option} { + proc t1 {} {} + proc t2 {} {} + set x " [info procs] " + list [string match {* t1 *} $x] [string match {* t2 *} $x] \ + [string match {* _undefined_ *} $x] +} {1 1 0} +test info-13.2 {info procs option} { + proc _tt1 {} {} + proc _tt2 {} {} + lsort [info pr _tt*] +} {_tt1 _tt2} +catch {rename _tt1 {}} +catch {rename _tt2 {}} +test info-13.3 {info procs option} { + list [catch {info procs 2 3} msg] $msg +} {1 {wrong # args: should be "info procs [pattern]"}} + +test info-14.1 {info script option} { + list [catch {info script x} msg] $msg +} {1 {wrong # args: should be "info script"}} +test info-14.2 {info script option} { + file tail [info s] +} info.test +catch {exec rm -f gorp.info} +exec cat > gorp.info << "info script\n" +test info-14.3 {info script option} { + list [source gorp.info] [file tail [info script]] +} {gorp.info info.test} +test info-14.4 {resetting "info script" after errors} { + catch {source ~_nobody_/foo} + file tail [info script] +} {info.test} +test info-14.5 {resetting "info script" after errors} { + catch {source _nonexistent_} + file tail [info script] +} {info.test} +exec rm -f gorp.info + +test info-15.1 {info tclversion option} { + set x [info tclversion] + scan $x "%d.%d%c" a b c +} 2 +test info-15.2 {info tclversion option} { + list [catch {info t 2} msg] $msg +} {1 {wrong # args: should be "info tclversion"}} + +test info-16.1 {info vars option} { + set a 1 + set b 2 + proc t1 {x y} { + global a b + set c 33 + return [info vars] + } + lsort [t1 18 19] +} {a b c x y} +test info-16.2 {info vars option} { + set xxx1 1 + set xxx2 2 + proc t1 {xxa y} { + global xxx1 xxx2 + set c 33 + return [info vars x*] + } + lsort [t1 18 19] +} {xxa xxx1 xxx2} +test info-16.3 {info vars option} { + lsort [info vars] +} [lsort [info globals]] +test info-16.4 {info vars option} { + list [catch {info vars a b} msg] $msg +} {1 {wrong # args: should be "info vars [pattern]"}} + +test info-17.1 {miscellaneous error conditions} { + list [catch {info} msg] $msg +} {1 {wrong # args: should be "info option ?arg arg ...?"}} +test info-17.2 {miscellaneous error conditions} { + list [catch {info gorp} msg] $msg +} {1 {bad option "gorp": should be args, body, cmdcount, commands, complete, default, exists, globals, level, library, locals, patchlevel, procs, script, tclversion, or vars}} +test info-17.3 {miscellaneous error conditions} { + list [catch {info c} msg] $msg +} {1 {bad option "c": should be args, body, cmdcount, commands, complete, default, exists, globals, level, library, locals, patchlevel, procs, script, tclversion, or vars}} +test info-17.4 {miscellaneous error conditions} { + list [catch {info l} msg] $msg +} {1 {bad option "l": should be args, body, cmdcount, commands, complete, default, exists, globals, level, library, locals, patchlevel, procs, script, tclversion, or vars}} diff --git a/vendor/x11iraf/obm/Tcl/tests/join.test b/vendor/x11iraf/obm/Tcl/tests/join.test new file mode 100644 index 00000000..0d01d4d9 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/tests/join.test @@ -0,0 +1,52 @@ +# Commands covered: join +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1991-1993 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. +# +# $Header: /user6/ouster/tcl/tests/RCS/join.test,v 1.4 93/02/06 16:01:33 ouster Exp $ (Berkeley) + +if {[string compare test [info procs test]] == 1} then {source defs} + +test join-1.1 {basic join commands} { + join {a b c} xyz +} axyzbxyzc +test join-1.2 {basic join commands} { + join {a b c} {} +} abc +test join-1.3 {basic join commands} { + join {} xyz +} {} +test join-1.4 {basic join commands} { + join {12 34 56} +} {12 34 56} + +test join-2.1 {join errors} { + list [catch join msg] $msg $errorCode +} {1 {wrong # args: should be "join list ?joinString?"} NONE} +test join-2.2 {join errors} { + list [catch {join a b c} msg] $msg $errorCode +} {1 {wrong # args: should be "join list ?joinString?"} NONE} +test join-2.3 {join errors} { + list [catch {join "a \{ c" 111} msg] $msg $errorCode +} {1 {unmatched open brace in list} NONE} diff --git a/vendor/x11iraf/obm/Tcl/tests/lindex.test b/vendor/x11iraf/obm/Tcl/tests/lindex.test new file mode 100644 index 00000000..f215a4ec --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/tests/lindex.test @@ -0,0 +1,73 @@ +# Commands covered: lindex +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1991-1993 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. +# +# $Header: /user6/ouster/tcl/tests/RCS/lindex.test,v 1.2 93/02/06 16:01:45 ouster Exp $ (Berkeley) + +if {[string compare test [info procs test]] == 1} then {source defs} + +test lindex-1.1 {basic tests} { + lindex {a b c} 0} a +test lindex-1.2 {basic tests} { + lindex {a {b c d} x} 1} {b c d} +test lindex-1.3 {basic tests} { + lindex {a b\ c\ d x} 1} {b c d} +test lindex-1.4 {basic tests} { + lindex {a b c} 3} {} +test lindex-1.5 {basic tests} { + list [catch {lindex {a b c} -1} msg] $msg +} {0 {}} + +test lindex-2.1 {error conditions} { + list [catch {lindex msg} msg] $msg +} {1 {wrong # args: should be "lindex list index"}} +test lindex-2.2 {error conditions} { + list [catch {lindex 1 2 3 4} msg] $msg +} {1 {wrong # args: should be "lindex list index"}} +test lindex-2.3 {error conditions} { + list [catch {lindex 1 2a2} msg] $msg +} {1 {expected integer but got "2a2"}} +test lindex-2.4 {error conditions} { + list [catch {lindex "a \{" 2} msg] $msg +} {1 {unmatched open brace in list}} +test lindex-2.5 {error conditions} { + list [catch {lindex {a {b c}d e} 2} msg] $msg +} {1 {list element in braces followed by "d" instead of space}} +test lindex-2.6 {error conditions} { + list [catch {lindex {a "b c"def ghi} 2} msg] $msg +} {1 {list element in quotes followed by "def" instead of space}} + +test lindex-3.1 {quoted elements} { + lindex {a "b c" d} 1 +} {b c} +test lindex-3.2 {quoted elements} { + lindex {"{}" b c} 0 +} {{}} +test lindex-3.3 {quoted elements} { + lindex {ab "c d \" x" y} 1 +} {c d " x} +test lindex-3.4 {quoted elements} { + lindex {a b {c d "e} {f g"}} 2 +} {c d "e} diff --git a/vendor/x11iraf/obm/Tcl/tests/link.test b/vendor/x11iraf/obm/Tcl/tests/link.test new file mode 100644 index 00000000..11817145 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/tests/link.test @@ -0,0 +1,148 @@ +# Commands covered: none +# +# This file contains a collection of tests for Tcl_LinkVar and related +# library procedures. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1993 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. +# +# $Header: /user6/ouster/tcl/tests/RCS/link.test,v 1.5 93/07/28 15:05:32 ouster Exp $ (Berkeley) + +if {[info commands testlink] == {}} { + puts "This application hasn't been compiled with the \"testlink\"" + puts "command, so I can't test Tcl_LinkVar et al." + return +} + +if {[string compare test [info procs test]] == 1} then {source defs} + +foreach i {int real bool string} { + catch {unset $i} +} +test link-1.1 {reading C variables from Tcl} { + testlink delete + testlink set 43 1.23 4 - + testlink create 1 1 1 1 + list $int $real $bool $string +} {43 1.23 1 NULL} +test link-1.2 {reading C variables from Tcl} { + testlink delete + testlink create 1 1 1 1 + testlink set -3 2 0 "A long string with spaces" + list $int $real $bool $string $int $real $bool $string +} {-3 2.0 0 {A long string with spaces} -3 2.0 0 {A long string with spaces}} + +test link-2.1 {writing C variables from Tcl} { + testlink delete + testlink set 43 1.23 4 - + testlink create 1 1 1 1 + set int "00721" + set real -8e13 + set bool true + set string abcdef + concat [testlink get] $int $real $bool $string +} {465 -8e+13 1 abcdef 00721 -8e13 true abcdef} +test link-2.2 {writing bad values into variables} { + testlink delete + testlink set 43 1.23 4 - + testlink create 1 1 1 1 + list [catch {set int 09a} msg] $msg $int +} {1 {can't set "int": variable must have integer value} 43} +test link-2.3 {writing bad values into variables} { + testlink delete + testlink set 43 1.23 4 - + testlink create 1 1 1 1 + list [catch {set real 1.x3} msg] $msg $real +} {1 {can't set "real": variable must have real value} 1.23} +test link-2.4 {writing bad values into variables} { + testlink delete + testlink set 43 1.23 4 - + testlink create 1 1 1 1 + list [catch {set bool gorp} msg] $msg $bool +} {1 {can't set "bool": variable must have boolean value} 1} + +test link-3.1 {read-only variables} { + testlink delete + testlink set 43 1.23 4 - + testlink create 0 1 1 0 + list [catch {set int 4} msg] $msg $int \ + [catch {set real 10.6} msg] $msg $real \ + [catch {set bool no} msg] $msg $bool \ + [catch {set string "new value"} msg] $msg $string +} {1 {can't set "int": linked variable is read-only} 43 0 10.6 10.6 0 no no 1 {can't set "string": linked variable is read-only} NULL} +test link-3.2 {read-only variables} { + testlink delete + testlink set 43 1.23 4 - + testlink create 1 0 0 1 + list [catch {set int 4} msg] $msg $int \ + [catch {set real 10.6} msg] $msg $real \ + [catch {set bool no} msg] $msg $bool \ + [catch {set string "new value"} msg] $msg $string +} {0 4 4 1 {can't set "real": linked variable is read-only} 1.23 1 {can't set "bool": linked variable is read-only} 1 0 {new value} {new value}} + +test link-4.1 {unsetting linked variables} { + testlink delete + testlink set -6 -2.1 0 stringValue + testlink create 1 1 1 1 + unset int real bool string + list [catch {set int} msg] $msg [catch {set real} msg] $msg \ + [catch {set bool} msg] $msg [catch {set string} msg] $msg +} {0 -6 0 -2.1 0 0 0 stringValue} +test link-4.2 {unsetting linked variables} { + testlink delete + testlink set -6 -2.1 0 stringValue + testlink create 1 1 1 1 + unset int real bool string + set int 102 + set real 16 + set bool true + set string newValue + testlink get +} {102 16.0 1 newValue} + +test link-5.1 {unlinking variables} { + testlink delete + testlink set -6 -2.1 0 stringValue + testlink delete + set int xx1 + set real qrst + set bool bogus + set string 12345 + testlink get +} {-6 -2.1 0 stringValue} +test link-5.2 {unlinking variables} { + testlink delete + testlink set -6 -2.1 0 stringValue + testlink create 1 1 1 1 + testlink delete + testlink set 25 14.7 7 - + list $int $real $bool $string +} {-6 -2.1 0 stringValue} + +test link-6.1 {errors in setting up link} { + testlink delete + catch {unset int} + set int(44) 1 + list [catch {testlink create 1 1 1 1} msg] $msg +} {1 {can't set "int": variable is array}} + +testlink delete +unset int real bool string diff --git a/vendor/x11iraf/obm/Tcl/tests/linsert.test b/vendor/x11iraf/obm/Tcl/tests/linsert.test new file mode 100644 index 00000000..0201405b --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/tests/linsert.test @@ -0,0 +1,91 @@ +# Commands covered: linsert +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1991-1993 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. +# +# $Header: /user6/ouster/tcl/tests/RCS/linsert.test,v 1.5 93/06/19 14:31:26 ouster Exp $ (Berkeley) + +if {[string compare test [info procs test]] == 1} then {source defs} + +test linsert-1.1 {linsert command} { + linsert {1 2 3 4 5} 0 a +} {a 1 2 3 4 5} +test linsert-1.2 {linsert command} { + linsert {1 2 3 4 5} 1 a +} {1 a 2 3 4 5} +test linsert-1.3 {linsert command} { + linsert {1 2 3 4 5} 2 a +} {1 2 a 3 4 5} +test linsert-1.4 {linsert command} { + linsert {1 2 3 4 5} 3 a +} {1 2 3 a 4 5} +test linsert-1.5 {linsert command} { + linsert {1 2 3 4 5} 4 a +} {1 2 3 4 a 5} +test linsert-1.6 {linsert command} { + linsert {1 2 3 4 5} 5 a +} {1 2 3 4 5 a} +test linsert-1.7 {linsert command} { + linsert {1 2 3 4 5} 2 one two \{three \$four +} {1 2 one two \{three {$four} 3 4 5} +test linsert-1.8 {linsert command} { + linsert {\{one \$two \{three \ four \ five} 2 a b c +} {\{one \$two a b c \{three \ four \ five} +test linsert-1.9 {linsert command} { + linsert {{1 2} {3 4} {5 6} {7 8}} 2 {x y} {a b} +} {{1 2} {3 4} {x y} {a b} {5 6} {7 8}} +test linsert-1.10 {linsert command} { + linsert {} 2 a b c +} {a b c} +test linsert-1.11 {linsert command} { + linsert {} 2 {} +} {{}} +test linsert-1.12 {linsert command} { + linsert {a b "c c" d e} 3 1 +} {a b "c c" 1 d e} +test linsert-1.13 {linsert command} { + linsert { a b c d} 0 1 2 +} {1 2 a b c d} +test linsert-1.14 {linsert command} { + linsert {a b c {d e f}} 4 1 2 +} {a b c {d e f} 1 2} +test linsert-1.15 {linsert command} { + linsert {a b c \{\ abc} 4 q r +} {a b c \{\ q r abc} +test linsert-1.16 {linsert command} { + linsert {a b c \{ abc} 4 q r +} {a b c \{ q r abc} + +test linsert-2.1 {linsert errors} { + list [catch linsert msg] $msg +} {1 {wrong # args: should be "linsert list index element ?element ...?"}} +test linsert-2.2 {linsert errors} { + list [catch {linsert a b} msg] $msg +} {1 {wrong # args: should be "linsert list index element ?element ...?"}} +test linsert-2.3 {linsert errors} { + list [catch {linsert a 12x 2} msg] $msg +} {1 {expected integer but got "12x"}} +test linsert-2.4 {linsert errors} { + list [catch {linsert \{ 12 2} msg] $msg +} {1 {unmatched open brace in list}} diff --git a/vendor/x11iraf/obm/Tcl/tests/list.test b/vendor/x11iraf/obm/Tcl/tests/list.test new file mode 100644 index 00000000..8bc07815 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/tests/list.test @@ -0,0 +1,87 @@ +# Commands covered: list +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1991-1993 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. +# +# $Header: /user6/ouster/tcl/tests/RCS/list.test,v 1.18 93/10/28 16:14:10 ouster Exp $ (Berkeley) + +if {[string compare test [info procs test]] == 1} then {source defs} + +# First, a bunch of individual tests + +test list-1.1 {basic tests} {list a b c} {a b c} +test list-1.2 {basic tests} {list {a b} c} {{a b} c} +test list-1.3 {basic tests} {list \{a b c} {\{a b c} +test list-1.4 {basic tests} "list a{}} b{} c}" "a\\{\\}\\} b{} c\\}" +test list-1.5 {basic tests} {list a\[ b\] } "{a\[} b\\]" +test list-1.6 {basic tests} {list c\ d\t } "{c } {d\t}" +test list-1.7 {basic tests} {list e\n f\$ } "{e\n} {f\$}" +test list-1.8 {basic tests} {list g\; h\\} {{g;} h\\} +test list-1.9 {basic tests} "list a\\\[} b\\\]} " "a\\\[\\\} b\\\]\\\}" +test list-1.10 {basic tests} "list c\\\} d\\t} " "c\\} d\\t\\}" +test list-1.11 {basic tests} "list e\\n} f\\$} " "e\\n\\} f\\$\\}" +test list-1.12 {basic tests} "list g\\;} h\\\\} " "g\\;\\} {h\\}}" +test list-1.13 {basic tests} {list a {{}} b} {a {{}} b} +test list-1.14 {basic tests} {list a b xy\\} "a b xy\\\\" +test list-1.15 {basic tests} "list a b\} e\\" "a b\\} e\\\\" +test list-1.16 {basic tests} "list a b\}\\\$ e\\\$\\" "a b\\}\\\$ e\\\$\\\\" +test list-1.17 {basic tests} {list a\f \{\f} "{a\f} \\\{\\f" +test list-1.18 {basic tests} {list a\r \{\r} "{a\r} \\\{\\r" +test list-1.19 {basic tests} {list a\v \{\v} "{a\v} \\\{\\v" +test list-1.20 {basic tests} {list \"\}\{} "\\\"\\}\\{" +test list-1.21 {basic tests} {list a b c\\\nd} "a b c\\\\\\nd" +test list-1.22 {basic tests} {list "{ab}\\"} \\{ab\\}\\\\ +test list-1.23 {basic tests} {list \{} "\\{" +test list-1.24 {basic tests} {list} {} + +# For the next round of tests create a list and then pick it apart +# with "index" to make sure that we get back exactly what went in. + +set num 1 +proc lcheck {a b c} { + global num d + set d [list $a $b $c] + test list-2.$num {what goes in must come out} {lindex $d 0} $a + set num [expr $num+1] + test list-2.$num {what goes in must come out} {lindex $d 1} $b + set num [expr $num+1] + test list-2.$num {what goes in must come out} {lindex $d 2} $c + set num [expr $num+1] +} +lcheck a b c +lcheck "a b" c\td e\nf +lcheck {{a b}} {} { } +lcheck \$ \$ab ab\$ +lcheck \; \;ab ab\; +lcheck \[ \[ab ab\[ +lcheck \\ \\ab ab\\ +lcheck {"} {"ab} {ab"} +lcheck {a b} { ab} {ab } +lcheck a{ a{b \{ab +lcheck a} a}b }ab +lcheck a\\} {a \}b} {a \{c} +lcheck xyz \\ 1\\\n2 +lcheck "{ab}\\" "{ab}xy" abc + +concat {} diff --git a/vendor/x11iraf/obm/Tcl/tests/llength.test b/vendor/x11iraf/obm/Tcl/tests/llength.test new file mode 100644 index 00000000..371e1657 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/tests/llength.test @@ -0,0 +1,49 @@ +# Commands covered: llength +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1991-1993 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. +# +# $Header: /user6/ouster/tcl/tests/RCS/llength.test,v 1.2 93/02/06 16:01:45 ouster Exp $ (Berkeley) + +if {[string compare test [info procs test]] == 1} then {source defs} + +test llength-1.1 {length of list} { + llength {a b c d} +} 4 +test llength-1.2 {length of list} { + llength {a b c {a b {c d}} d} +} 5 +test llength-1.3 {length of list} { + llength {} +} 0 + +test llength-2.1 {error conditions} { + list [catch {llength} msg] $msg +} {1 {wrong # args: should be "llength list"}} +test llength-2.2 {error conditions} { + list [catch {llength 123 2} msg] $msg +} {1 {wrong # args: should be "llength list"}} +test llength-2.3 {error conditions} { + list [catch {llength "a b c \{"} msg] $msg +} {1 {unmatched open brace in list}} diff --git a/vendor/x11iraf/obm/Tcl/tests/lrange.test b/vendor/x11iraf/obm/Tcl/tests/lrange.test new file mode 100644 index 00000000..b8aef6bf --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/tests/lrange.test @@ -0,0 +1,79 @@ +# Commands covered: lrange +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1991-1993 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. +# +# $Header: /user6/ouster/tcl/tests/RCS/lrange.test,v 1.2 93/02/06 16:01:44 ouster Exp $ (Berkeley) + +if {[string compare test [info procs test]] == 1} then {source defs} + +test lrange-1.1 {range of list elements} { + lrange {a b c d} 1 2 +} {b c} +test lrange-1.2 {range of list elements} { + lrange {a {bcd e {f g {}}} l14 l15 d} 1 1 +} {{bcd e {f g {}}}} +test lrange-1.3 {range of list elements} { + lrange {a {bcd e {f g {}}} l14 l15 d} 3 end +} {l15 d} +test lrange-1.4 {range of list elements} { + lrange {a {bcd e {f g {}}} l14 l15 d} 4 10000 +} {d} +test lrange-1.5 {range of list elements} { + lrange {a {bcd e {f g {}}} l14 l15 d} 4 3 +} {} +test lrange-1.6 {range of list elements} { + lrange {a {bcd e {f g {}}} l14 l15 d} 10 11 +} {} +test lrange-1.7 {range of list elements} { + lrange {a b c d e} -1 2 +} {a b c} +test lrange-1.8 {range of list elements} { + lrange {a b c d e} -2 -1 +} {} +test lrange-1.9 {range of list elements} { + lrange {a b c d e} -2 e +} {a b c d e} +test lrange-1.10 {range of list elements} { + lrange "a b\{c d" 1 2 +} "b\{c d" + +test lrange-2.1 {error conditions} { + list [catch {lrange a b} msg] $msg +} {1 {wrong # args: should be "lrange list first last"}} +test lrange-2.2 {error conditions} { + list [catch {lrange a b 6 7} msg] $msg +} {1 {wrong # args: should be "lrange list first last"}} +test lrange-2.3 {error conditions} { + list [catch {lrange a b 6} msg] $msg +} {1 {expected integer but got "b"}} +test lrange-2.4 {error conditions} { + list [catch {lrange a 0 enigma} msg] $msg +} {1 {expected integer or "end" but got "enigma"}} +test lrange-2.5 {error conditions} { + list [catch {lrange "a \{b c" 3 4} msg] $msg +} {1 {unmatched open brace in list}} +test lrange-2.6 {error conditions} { + list [catch {lrange "a b c \{ d e" 1 4} msg] $msg +} {1 {unmatched open brace in list}} diff --git a/vendor/x11iraf/obm/Tcl/tests/lreplace.test b/vendor/x11iraf/obm/Tcl/tests/lreplace.test new file mode 100644 index 00000000..d3025288 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/tests/lreplace.test @@ -0,0 +1,106 @@ +# Commands covered: lreplace +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1991-1993 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. +# +# $Header: /user6/ouster/tcl/tests/RCS/lreplace.test,v 1.5 93/02/06 16:01:39 ouster Exp $ (Berkeley) + +if {[string compare test [info procs test]] == 1} then {source defs} + +test lreplace-1.1 {lreplace command} { + lreplace {1 2 3 4 5} 0 0 a +} {a 2 3 4 5} +test lreplace-1.2 {lreplace command} { + lreplace {1 2 3 4 5} 1 1 a +} {1 a 3 4 5} +test lreplace-1.3 {lreplace command} { + lreplace {1 2 3 4 5} 2 2 a +} {1 2 a 4 5} +test lreplace-1.4 {lreplace command} { + lreplace {1 2 3 4 5} 3 3 a +} {1 2 3 a 5} +test lreplace-1.5 {lreplace command} { + lreplace {1 2 3 4 5} 4 4 a +} {1 2 3 4 a} +test lreplace-1.6 {lreplace command} { + lreplace {1 2 3 4 5} 4 5 a +} {1 2 3 4 a} +test lreplace-1.7 {lreplace command} { + lreplace {1 2 3 4 5} -1 -1 a +} {a 2 3 4 5} +test lreplace-1.8 {lreplace command} { + lreplace {1 2 3 4 5} 2 end a b c d +} {1 2 a b c d} +test lreplace-1.9 {lreplace command} { + lreplace {1 2 3 4 5} 0 3 +} {5} +test lreplace-1.10 {lreplace command} { + lreplace {1 2 3 4 5} 0 4 +} {} +test lreplace-1.11 {lreplace command} { + lreplace {1 2 3 4 5} 0 1 +} {3 4 5} +test lreplace-1.12 {lreplace command} { + lreplace {1 2 3 4 5} 2 3 +} {1 2 5} +test lreplace-1.13 {lreplace command} { + lreplace {1 2 3 4 5} 3 end +} {1 2 3} +test lreplace-1.14 {lreplace command} { + lreplace {1 2 3 4 5} -1 4 a b c +} {a b c} +test lreplace-1.15 {lreplace command} { + lreplace {a b "c c" d e f} 3 3 +} {a b "c c" e f} +test lreplace-1.16 {lreplace command} { + lreplace { 1 2 3 4 5} 0 0 a +} {a 2 3 4 5} +test lreplace-1.17 {lreplace command} { + lreplace {1 2 3 4 "5 6"} 4 4 a +} {1 2 3 4 a} +test lreplace-1.18 {lreplace command} { + lreplace {1 2 3 4 {5 6}} 4 4 a +} {1 2 3 4 a} + +test lreplace-2.1 {lreplace errors} { + list [catch lreplace msg] $msg +} {1 {wrong # args: should be "lreplace list first last ?element element ...?"}} +test lreplace-2.2 {lreplace errors} { + list [catch {lreplace a b} msg] $msg +} {1 {wrong # args: should be "lreplace list first last ?element element ...?"}} +test lreplace-2.3 {lreplace errors} { + list [catch {lreplace x a 10} msg] $msg +} {1 {expected integer but got "a"}} +test lreplace-2.4 {lreplace errors} { + list [catch {lreplace x 10 x} msg] $msg +} {1 {bad index "x": must be integer or "end"}} +test lreplace-2.5 {lreplace errors} { + list [catch {lreplace x 10 1x} msg] $msg +} {1 {expected integer but got "1x"}} +test lreplace-2.6 {lreplace errors} { + list [catch {lreplace x 3 2} msg] $msg +} {1 {first index must not be greater than second}} +test lreplace-2.7 {lreplace errors} { + list [catch {lreplace x 1 1} msg] $msg +} {1 {list doesn't contain element 1}} diff --git a/vendor/x11iraf/obm/Tcl/tests/lsearch.test b/vendor/x11iraf/obm/Tcl/tests/lsearch.test new file mode 100644 index 00000000..73bbdaf2 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/tests/lsearch.test @@ -0,0 +1,81 @@ +# Commands covered: lsearch +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1991-1993 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. +# +# $Header: /user6/ouster/tcl/tests/RCS/lsearch.test,v 1.3 93/05/06 16:18:04 ouster Exp $ (Berkeley) + +if {[string compare test [info procs test]] == 1} then {source defs} + +set x {abcd bbcd 123 234 345} +test lsearch-1.1 {lsearch command} { + lsearch $x 123 +} 2 +test lsearch-1.2 {lsearch command} { + lsearch $x 3456 +} -1 +test lsearch-1.3 {lsearch command} { + lsearch $x *5 +} 4 +test lsearch-1.4 {lsearch command} { + lsearch $x *bc* +} 0 + +test lsearch-2.1 {search modes} { + lsearch -exact {xyz bbcc *bc*} *bc* +} 2 +test lsearch-2.2 {search modes} { + lsearch -exact {b.x ^bc xy bcx} ^bc +} 1 +test lsearch-2.3 {search modes} { + list [catch {lsearch -regexp {xyz bbcc *bc*} *bc*} msg] $msg +} {1 {couldn't compile regular expression pattern: ?+* follows nothing}} +test lsearch-2.4 {search modes} { + lsearch -regexp {b.x ^bc xy bcx} ^bc +} 3 +test lsearch-2.5 {search modes} { + lsearch -glob {xyz bbcc *bc*} *bc* +} 1 +test lsearch-2.6 {search modes} { + lsearch -glob {b.x ^bc xy bcx} ^bc +} 1 +test lsearch-2.7 {search modes} { + list [catch {lsearch -glib {b.x bx xy bcx} b.x} msg] $msg +} {1 {bad search mode "-glib": must be -exact, -glob, or -regexp}} + +test lsearch-3.1 {lsearch errors} { + list [catch lsearch msg] $msg +} {1 {wrong # args: should be "lsearch ?mode? list pattern"}} +test lsearch-3.2 {lsearch errors} { + list [catch {lsearch a} msg] $msg +} {1 {wrong # args: should be "lsearch ?mode? list pattern"}} +test lsearch-3.3 {lsearch errors} { + list [catch {lsearch a b c} msg] $msg +} {1 {bad search mode "a": must be -exact, -glob, or -regexp}} +test lsearch-3.4 {lsearch errors} { + list [catch {lsearch a b c d} msg] $msg +} {1 {wrong # args: should be "lsearch ?mode? list pattern"}} +test lsearch-3.5 {lsearch errors} { + list [catch {lsearch "\{" b} msg] $msg +} {1 {unmatched open brace in list}} diff --git a/vendor/x11iraf/obm/Tcl/tests/lsort.test b/vendor/x11iraf/obm/Tcl/tests/lsort.test new file mode 100644 index 00000000..0020eb5c --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/tests/lsort.test @@ -0,0 +1,136 @@ +# Commands covered: lsort +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1991-1993 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. +# +# $Header: /user6/ouster/tcl/tests/RCS/lsort.test,v 1.4 93/10/22 14:25:01 ouster Exp $ (Berkeley) + +if {[string compare test [info procs test]] == 1} then {source defs} + +test lsort-1.1 {lsort command} { + lsort {abdeq ab 1 ac a} +} {1 a ab abdeq ac} +test lsort-1.2 {lsort command} { + lsort -decreasing {abdeq ab 1 ac a} +} {ac abdeq ab a 1} +test lsort-1.3 {lsort command} { + lsort -increasing {abdeq ab 1 ac a} +} {1 a ab abdeq ac} +test lsort-1.4 {lsort command} { + lsort {{one long element}} +} {{one long element}} +test lsort-1.5 {lsort command} { + lsort {} +} {} +test lsort-1.6 {lsort with characters needing backslashes} { + lsort {$ \\ [] \{} +} {{$} {[]} \\ \{} + +test lsort-2.1 {lsort -integer} { + lsort -integer -inc {1 180 62 040 180 -42 33 0x40} +} {-42 1 040 33 62 0x40 180 180} +test lsort-2.2 {lsort -integer} { + lsort -int -dec {1 180 62 040 180 -42 33 0x40} +} {180 180 0x40 62 33 040 1 -42} +test lsort-2.3 {lsort -integer} { + list [catch {lsort -integer {xxx 180.2 62 040 180 -42 33 0x40}} msg] $msg $errorInfo +} {1 {expected integer but got "xxx"} {expected integer but got "xxx" + (converting list element from string to integer) + invoked from within +"lsort -integer {xxx 180.2 62 040 180 -42 33 0x40}"}} +test lsort-2.4 {lsort -integer} { + list [catch {lsort -integer {1 180.2 62 040 180 -42 33 0x40}} msg] $msg $errorInfo +} {1 {expected integer but got "180.2"} {expected integer but got "180.2" + (converting list element from string to integer) + invoked from within +"lsort -integer {1 180.2 62 040 180 -42 33 0x40}"}} + +test lsort-3.1 {lsort -real} { + lsort -real {1 180.1 62 040 180 -42.7 33} +} {-42.7 1 33 040 62 180 180.1} +test lsort-3.2 {lsort -real} { + lsort -r -d {1 180.1 62 040 180 -42.7 33} +} {180.1 180 62 040 33 1 -42.7} +test lsort-3.3 {lsort -real} { + list [catch {lsort -real -inc {xxx 20 62 180 -42.7 33}} msg] $msg $errorInfo +} {1 {expected floating-point number but got "xxx"} {expected floating-point number but got "xxx" + (converting list element from string to real) + invoked from within +"lsort -real -inc {xxx 20 62 180 -42.7 33}"}} +test lsort-3.4 {lsort -real} { + list [catch {lsort -real -inc {1 0x40 62 180 -42.7 33}} msg] $msg $errorInfo +} {1 {expected floating-point number but got "0x40"} {expected floating-point number but got "0x40" + (converting list element from string to real) + invoked from within +"lsort -real -inc {1 0x40 62 180 -42.7 33}"}} + +proc lsort1 {a b} { + expr {2*([string match x* $a] - [string match x* $b]) + + [string match *y $a] - [string match *y $b]} +} +proc lsort2 {a b} { + error "comparison error" +} +proc lsort3 {a b} { + concat "foobar" +} + +test lsort-4.1 {lsort -command} { + lsort -command lsort1 {xxx yyy abc {xx y}} +} {abc yyy xxx {xx y}} +test lsort-4.2 {lsort -command} { + lsort -command lsort1 -dec {xxx yyy abc {xx y}} +} {{xx y} xxx yyy abc} +test lsort-4.3 {lsort -command} { + list [catch {lsort -command lsort2 -dec {1 1 1 1}} msg] $msg $errorInfo +} {1 {comparison error} {comparison error + while executing +"error "comparison error"" + (procedure "lsort2" line 2) + invoked from within +"lsort2 1 1" + (user-defined comparison command) + invoked from within +"lsort -command lsort2 -dec {1 1 1 1}"}} +test lsort-4.4 {lsort -command} { + list [catch {lsort -command lsort3 -dec {1 2 3 4}} msg] $msg $errorInfo +} {1 {comparison command returned non-numeric result} {comparison command returned non-numeric result + while executing +"lsort -command lsort3 -dec {1 2 3 4}"}} +test lsort-4.5 {lsort -command} { + list [catch {lsort -command {xxx yyy xxy abc}} msg] $msg +} {1 {"-command" must be followed by comparison command}} + +test lsort-5.1 {lsort errors} { + list [catch lsort msg] $msg +} {1 {wrong # args: should be "lsort ?-ascii? ?-integer? ?-real? ?-increasing? ?-decreasing? ?-command string? list"}} +test lsort-5.2 {lsort errors} { + list [catch {lsort a b} msg] $msg +} {1 {bad switch "a": must be -ascii, -integer, -real, -increasing -decreasing, or -command}} +test lsort-5.3 {lsort errors} { + list [catch {lsort "\{"} msg] $msg +} {1 {unmatched open brace in list}} +test lsort-5.4 {lsort errors} { + list [catch {lsort -in {1 180.0 040 62 180 -42.7 33}} msg] $msg +} {1 {bad switch "-in": must be -ascii, -integer, -real, -increasing -decreasing, or -command}} diff --git a/vendor/x11iraf/obm/Tcl/tests/misc.test b/vendor/x11iraf/obm/Tcl/tests/misc.test new file mode 100644 index 00000000..d05a63f5 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/tests/misc.test @@ -0,0 +1,84 @@ +# Commands covered: various +# +# This file contains a collection of miscellaneous Tcl tests that +# don't fit naturally in any of the other test files. Many of these +# tests are pathological cases that caused bugs in earlier Tcl +# releases. +# +# Copyright (c) 1992-1993 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. +# +# $Header: /user6/ouster/tcl/tests/RCS/misc.test,v 1.3 93/10/07 11:41:23 ouster Exp $ (Berkeley) + +if {[string compare test [info procs test]] == 1} then {source defs} + +test misc-1.1 {error in variable ref. in command in array reference} { + proc tstProc {} { + global a + + set tst $a([winfo name $zz]) + # this is a bogus comment + # this is a bogus comment + # this is a bogus comment + # this is a bogus comment + # this is a bogus comment + # this is a bogus comment + # this is a bogus comment + # this is a bogus comment + } + set msg {} + list [catch tstProc msg] $msg +} {1 {can't read "zz": no such variable}} +test misc-1.2 {error in variable ref. in command in array reference} { + proc tstProc {} " + global a + + set tst \$a(\[winfo name \$\{zz) + # this is a bogus comment + # this is a bogus comment + # this is a bogus comment + # this is a bogus comment + # this is a bogus comment + # this is a bogus comment + # this is a bogus comment + # this is a bogus comment + " + set msg {} + list [catch tstProc msg] $msg $errorInfo +} [list 1 {missing close-brace for variable name} \ +[format {missing close-brace for variable name + while executing +"winfo name $%szz) + # this is a bogus comment + # this is a bogus comment + # this is a bogus comment + # this is a bogus comment + # this is a bogus commen ..." + (parsing index for array "a") + invoked from within +"set tst $a([winfo name $%szz) + # this is a bogus comment + # this is a bogus comment + # this is a bogus comment + # this is a bogus comment + # this is a ..." + (procedure "tstProc" line 4) + invoked from within +"tstProc"} \{ \{]] diff --git a/vendor/x11iraf/obm/Tcl/tests/open.test b/vendor/x11iraf/obm/Tcl/tests/open.test new file mode 100644 index 00000000..950873d5 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/tests/open.test @@ -0,0 +1,662 @@ +# Commands covered: open, close, gets, puts, read, seek, tell, eof, flush +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1991-1993 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. +# +# $Header: /user6/ouster/tcl/tests/RCS/open.test,v 1.19 93/10/18 08:52:24 ouster Exp $ (Berkeley) + +if {[string compare test [info procs test]] == 1} then {source defs} + +catch {exec rm -f test1 test2 test3} +exec cat > test1 << "Two lines: this one\nand this one\n" +exec cat > test2 << "line1\nline2\nline3\nline4\nline5\n" + +test open-1.1 {open command (files only)} { + set f [open test1] + set x [gets $f] + close $f + set x +} {Two lines: this one} +test open-1.2 {open command (files only)} { + set f [open test1] + set f2 [open test2] + set f3 [open test1] + set f4 [open test1] + set x [list [gets $f] [gets $f2] [gets $f3] [gets $f4] \ + [gets $f] [gets $f2]] + close $f + close $f2 + close $f3 + close $f4 + set x +} {{Two lines: this one} line1 {Two lines: this one} {Two lines: this one} {and this one} line2} +test open-1.3 {open command (files only)} { + set f [open test3 w] + puts $f xyz + close $f + exec cat test3 +} "xyz" +test open-1.4 {open command (files only)} { + set f [open test3 w] + puts $f xyz + close $f + set f [open test3 a] + puts $f 123 + close $f + exec cat test3 +} "xyz\n123" +test open-1.5 {open command (files only)} { + set f [open test3 w] + puts $f xyz\n123 + close $f + set f [open test3 r+] + set x [gets $f] + seek $f 0 current + puts $f 456 + close $f + list $x [exec cat test3] +} "xyz {xyz +456}" +test open-1.6 {open command (files only)} { + set f [open test3 w] + puts $f xyz\n123 + close $f + set f [open test3 w+] + puts $f xyzzy + seek $f 2 + set x [gets $f] + close $f + list $x [exec cat test3] +} "zzy xyzzy" +test open-1.7 {open command (files only)} { + set f [open test3 w] + puts $f xyz\n123 + close $f + set f [open test3 a+] + puts $f xyzzy + flush $f + set x [tell $f] + seek $f -4 cur + set y [gets $f] + close $f + list $x [exec cat test3] $y +} {14 {xyz +123 +xyzzy} zzy} + +test open-2.1 {errors in open command} { + list [catch {open} msg] $msg +} {1 {wrong # args: should be "open filename ?access? ?permissions?"}} +test open-2.2 {errors in open command} { + list [catch {open a b c d} msg] $msg +} {1 {wrong # args: should be "open filename ?access? ?permissions?"}} +test open-2.3 {errors in open command} { + list [catch {open test1 x} msg] $msg +} {1 {illegal access mode "x"}} +test open-2.4 {errors in open command} { + list [catch {open test1 rw} msg] $msg +} {1 {illegal access mode "rw"}} +test open-2.5 {errors in open command} { + list [catch {open test1 r+1} msg] $msg +} {1 {illegal access mode "r+1"}} +test open-2.6 {errors in open command} { + string tolower [list [catch {open _non_existent_} msg] $msg $errorCode] +} {1 {couldn't open "_non_existent_": no such file or directory} {posix enoent {no such file or directory}}} + +if {![file exists ~/_test_] && [file writable ~]} { + test open-3.1 {tilde substitution in open} { + set f [open ~/_test_ w] + puts $f "Some text" + close $f + set x [file exists $env(HOME)/_test_] + exec rm -f $env(HOME)/_test_ + set x + } 1 +} +test open-3.2 {tilde substitution in open} { + set home $env(HOME) + unset env(HOME) + set x [list [catch {open ~/foo} msg] $msg] + set env(HOME) $home + set x +} {1 {couldn't find HOME environment variable to expand "~/foo"}} + +test open-4.1 {file id parsing errors} { + list [catch {eof gorp} msg] $msg $errorCode +} {1 {bad file identifier "gorp"} NONE} +test open-4.2 {file id parsing errors} { + list [catch {eof filex} msg] $msg +} {1 {bad file identifier "filex"}} +test open-4.3 {file id parsing errors} { + list [catch {eof file12a} msg] $msg +} {1 {bad file identifier "file12a"}} +test open-4.4 {file id parsing errors} { + list [catch {eof file123} msg] $msg +} {1 {file "file123" isn't open}} +test open-4.5 {file id parsing errors} { + list [catch {eof file1} msg] $msg +} {0 0} +test open-4.5 {file id parsing errors} { + list [catch {eof stdin} msg] $msg +} {0 0} +test open-4.6 {file id parsing errors} { + list [catch {eof stdout} msg] $msg +} {0 0} +test open-4.7 {file id parsing errors} { + list [catch {eof stderr} msg] $msg +} {0 0} +test open-4.8 {file id parsing errors} { + list [catch {eof stderr1} msg] $msg +} {1 {bad file identifier "stderr1"}} +set f [open test1] +close $f +set expect "1 {file \"$f\" isn't open}" +test open-4.9 {file id parsing errors} { + list [catch {eof $f} msg] $msg +} $expect + +test open-5.1 {close command (files only)} { + list [catch {close} msg] $msg $errorCode +} {1 {wrong # args: should be "close fileId"} NONE} +test open-5.2 {close command (files only)} { + list [catch {close a b} msg] $msg $errorCode +} {1 {wrong # args: should be "close fileId"} NONE} +test open-5.3 {close command (files only)} { + list [catch {close gorp} msg] $msg $errorCode +} {1 {bad file identifier "gorp"} NONE} +test open-5.4 {close command (files only)} { + list [catch {close file4} msg] \ + [string range $msg [string first {" } $msg] end] $errorCode +} {1 {" isn't open} NONE} + +test open-6.1 {puts command} { + list [catch {puts} msg] $msg $errorCode +} {1 {wrong # args: should be "puts" ?-nonewline? ?fileId? string} NONE} +test open-6.2 {puts command} { + list [catch {puts a b c d} msg] $msg $errorCode +} {1 {wrong # args: should be "puts" ?-nonewline? ?fileId? string} NONE} +test open-6.3 {puts command} { + list [catch {puts a b nonewlinx} msg] $msg $errorCode +} {1 {bad argument "nonewlinx": should be "nonewline"} NONE} +test open-6.4 {puts command} { + list [catch {puts gorp "New text"} msg] $msg $errorCode +} {1 {bad file identifier "gorp"} NONE} +test open-6.5 {puts command} { + set f [open test3] + set x [list [catch {puts $f "New text"} msg] \ + [string range $msg [string first " " $msg] end] $errorCode] + close $f + set x +} {1 { wasn't opened for writing} NONE} +test open-6.6 {puts command} { + set f [open test3 w] + puts -nonewline $f "Text1" + puts -nonewline $f " Text 2" + puts $f " Text 3" + close $f + exec cat test3 +} {Text1 Text 2 Text 3} + +test open-7.1 {gets command} { + list [catch {gets} msg] $msg $errorCode +} {1 {wrong # args: should be "gets fileId ?varName?"} NONE} +test open-7.2 {gets command} { + list [catch {gets a b c} msg] $msg $errorCode +} {1 {wrong # args: should be "gets fileId ?varName?"} NONE} +test open-7.3 {gets command} { + list [catch {gets a} msg] $msg $errorCode +} {1 {bad file identifier "a"} NONE} +test open-7.4 {gets command} { + set f [open test3 w] + set x [list [catch {gets $f} msg] \ + [string range $msg [string first " " $msg] end] $errorCode] + close $f + set x +} {1 { wasn't opened for reading} NONE} +set f [open test3 w] +puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" +puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" +puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" +puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" +puts $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" +close $f +test open-7.5 {gets command with long line} { + set f [open test3] + set x [gets $f] + close $f + set x +} {abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ} +test open-7.6 {gets command with long line} { + set f [open test3] + set x [gets $f y] + close $f + list $x $y +} {260 abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ} +test open-7.7 {gets command and end of file} { + set f [open test3 w] + puts -nonewline $f "Test1\nTest2" + close $f + set f [open test3] + set x {} + set y {} + lappend x [gets $f y] $y + set y {} + lappend x [gets $f y] $y + set y {} + lappend x [gets $f y] $y + close $f + set x +} {5 Test1 5 Test2 -1 {}} +set f [open test3 w] +puts $f "Line 1" +puts $f "Line 2" +close $f +test open-7.8 {gets command and bad variable} { + catch {unset x} + set x 24 + set f [open test3 r] + set result [list [catch {gets $f x(0)} msg] $msg] + close $f + set result +} {1 {can't set "x(0)": variable isn't array}} + +test open-8.1 {read command} { + list [catch {read} msg] $msg $errorCode +} {1 {wrong # args: should be "read fileId ?numBytes?" or "read ?-nonewline? fileId"} NONE} +test open-8.2 {read command} { + list [catch {read -nonewline} msg] $msg $errorCode +} {1 {bad file identifier "-nonewline"} NONE} +test open-8.3 {read command} { + list [catch {read a b c} msg] $msg $errorCode +} {1 {wrong # args: should be "read fileId ?numBytes?" or "read ?-nonewline? fileId"} NONE} +test open-8.4 {read command} { + list [catch {read -nonew file4} msg] $msg $errorCode +} {1 {bad file identifier "-nonew"} NONE} +test open-8.5 {read command} { + list [catch {read stdin foo} msg] $msg $errorCode +} {1 {bad argument "foo": should be "nonewline"} NONE} +test open-8.6 {read command} { + list [catch {read file10} msg] $msg $errorCode +} {1 {file "file10" isn't open} NONE} +test open-8.7 {read command} { + set f [open test3 w] + set x [list [catch {read $f} msg] \ + [string range $msg [string first " " $msg] end] $errorCode] + close $f + set x +} {1 { wasn't opened for reading} NONE} +test open-8.8 {read command} { + set f [open test1] + set x [list [catch {read $f 12z} msg] $msg $errorCode] + close $f + set x +} {1 {expected integer but got "12z"} NONE} +test open-898 {read command} { + set f [open test1] + set x [list [catch {read $f z} msg] $msg $errorCode] + close $f + set x +} {1 {bad argument "z": should be "nonewline"} NONE} +test open-8.10 {read command} { + set f [open test1] + set x [list [read $f 1] [read $f 2] [read $f]] + close $f + set x +} {T wo { lines: this one +and this one +}} +test open-8.11 {read command, with over-large count} { + set f [open test1] + set x [read $f 100] + close $f + set x +} {Two lines: this one +and this one +} +test open-8.12 {read command, -nonewline switch} { + set f [open test1] + set x [read -nonewline $f] + close $f + set x +} {Two lines: this one +and this one} + +test open-9.1 {seek command} { + list [catch {seek foo} msg] $msg $errorCode +} {1 {wrong # args: should be "seek fileId offset ?origin?"} NONE} +test open-9.2 {seek command} { + list [catch {seek foo a b c} msg] $msg $errorCode +} {1 {wrong # args: should be "seek fileId offset ?origin?"} NONE} +test open-9.3 {seek command} { + list [catch {seek foo 0} msg] $msg $errorCode +} {1 {bad file identifier "foo"} NONE} +test open-9.4 {seek command} { + set f [open test2] + set x [list [catch {seek $f xyz} msg] $msg $errorCode] + close $f + set x +} {1 {expected integer but got "xyz"} NONE} +test open-9.5 {seek command} { + set f [open test2] + set x [list [catch {seek $f 100 gorp} msg] $msg $errorCode] + close $f + set x +} {1 {bad origin "gorp": should be start, current, or end} NONE} +set f [open test3 w] +puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" +close $f +test open-9.6 {seek command} { + set f [open test3] + set x [read $f 1] + seek $f 3 + lappend x [read $f 1] + seek $f 0 start + lappend x [read $f 1] + seek $f 10 current + lappend x [read $f 1] + seek $f -2 end + lappend x [read $f 1] + seek $f 50 end + lappend x [read $f 1] + seek $f 1 + lappend x [read $f 1] + close $f + set x +} {a d a l Y {} b} + +test open-10.1 {tell command} { + list [catch {tell} msg] $msg $errorCode +} {1 {wrong # args: should be "tell fileId"} NONE} +test open-10.2 {tell command} { + list [catch {tell a b} msg] $msg $errorCode +} {1 {wrong # args: should be "tell fileId"} NONE} +test open-10.3 {tell command} { + list [catch {tell a} msg] $msg $errorCode +} {1 {bad file identifier "a"} NONE} +test open-10.4 {tell command} { + set f [open test2] + set x [tell $f] + read $f 3 + lappend x [tell $f] + seek $f 2 + lappend x [tell $f] + seek $f 10 current + lappend x [tell $f] + seek $f 0 end + lappend x [tell $f] + close $f + set x +} {0 3 2 12 30} + +test open-11.1 {eof command} { + list [catch {eof} msg] $msg $errorCode +} {1 {wrong # args: should be "eof fileId"} NONE} +test open-11.2 {eof command} { + list [catch {eof a b} msg] $msg $errorCode +} {1 {wrong # args: should be "eof fileId"} NONE} +test open-11.3 {eof command} { + list [catch {eof file100} msg] $msg $errorCode +} {1 {file "file100" isn't open} NONE} +test open-11.4 {eof command} { + set f [open test1] + set x [eof $f] + lappend x [eof $f] + gets $f + lappend x [eof $f] + gets $f + lappend x [eof $f] + gets $f + lappend x [eof $f] + lappend x [eof $f] + close $f + set x +} {0 0 0 0 1 1} + +test open-12.1 {flush command} { + list [catch {flush} msg] $msg $errorCode +} {1 {wrong # args: should be "flush fileId"} NONE} +test open-12.2 {flush command} { + list [catch {flush a b} msg] $msg $errorCode +} {1 {wrong # args: should be "flush fileId"} NONE} +test open-12.3 {flush command} { + list [catch {flush a} msg] $msg $errorCode +} {1 {bad file identifier "a"} NONE} +test open-12.4 {flush command} { + set f [open test3] + set x [list [catch {flush $f} msg] \ + [string range $msg [string first " " $msg] end] $errorCode] + close $f + set x +} {1 { wasn't opened for writing} NONE} +test open-12.5 {flush command} { + set f [open test3 w] + puts $f "Line 1" + puts $f "Line 2" + set f2 [open test3] + set x {} + lappend x [read -nonewline $f2] + close $f2 + flush $f + set f2 [open test3] + lappend x [read -nonewline $f2] + close $f2 + close $f + set x +} {{} {Line 1 +Line 2}} + +test open-13.1 {I/O to command pipelines} { + list [catch {open "| cat < test1 > test3" w} msg] $msg $errorCode +} {1 {can't write input to command: standard input was redirected} NONE} +test open-13.2 {I/O to command pipelines} { + list [catch {open "| echo > test3" r} msg] $msg $errorCode +} {1 {can't read output from command: standard output was redirected} NONE} +test open-13.3 {I/O to command pipelines} { + list [catch {open "| echo > test3" r+} msg] $msg $errorCode +} {1 {can't read output from command: standard output was redirected} NONE} +test open-13.4 {writing to command pipelines} { + exec rm test3 + set f [open "| cat | cat > test3" w] + puts $f "Line 1" + puts $f "Line 2" + close $f + exec cat test3 +} {Line 1 +Line 2} +test open-13.5 {reading from command pipelines} { + set f [open "| cat test2" r] + set x [list [gets $f] [gets $f] [gets $f]] + close $f + set x +} {line1 line2 line3} +test open-13.6 {both reading and writing from/to command pipelines} { + set f [open "| cat -u" r+] + puts $f "Line1" + flush $f + set x [gets $f] + close $f + set x +} {Line1} +test open-13.7 {errors in command pipelines} { + set f [open "|gorp"] + list [catch {close $f} msg] $msg [lindex $errorCode 0] [lindex $errorCode 2] +} {1 {couldn't find "gorp" to execute} CHILDSTATUS 1} +test open-13.8 {errors in command pipelines} { + set f [open "|gorp" w] + exec sleep 1 + puts $f output + set x [list [catch {flush $f} msg] [concat \ + [string range $msg 0 [string first {"} $msg]] \ + [string range $msg [string first : $msg] end]] $errorCode] + catch {close $f} + string tolower $x +} {1 {error flushing " : broken pipe} {posix epipe {broken pipe}}} +test open-13.9 {errors in command pipelines} { + set f [open "|gorp" w] + list [catch {close $f} msg] $msg \ + [lindex $errorCode 0] [lindex $errorCode 2] +} {1 {couldn't find "gorp" to execute} CHILDSTATUS 1} +test open-13.10 {errors in command pipelines} { + set f [open "|gorp" w] + exec sleep 1 + puts $f output + string tolower [list [catch {close $f} msg] [concat \ + [string range $msg 0 [string first {"} $msg]] \ + [string range $msg [string first : $msg] end]] \ + [lindex $errorCode 0] [lindex $errorCode 2]] +} {1 {error closing " : broken pipe +couldn't find "gorp" to execute} childstatus 1} + +test open-14.1 {POSIX open access modes: RDONLY} { + set f [open test1 RDONLY] + set x [list [gets $f] [catch {puts $f Test} msg] $msg] + close $f + + # The regsub is needed to avoid false errors if the file + # number varies from system to system. + + regsub {"file."} $x {"file"} x + set x +} {{Two lines: this one} 1 {"file" wasn't opened for writing}} +test open-14.2 {POSIX open access modes: RDONLY} { + catch {exec rm -f test3} + string tolower [list [catch {open test3 RDONLY} msg] $msg] +} {1 {couldn't open "test3": no such file or directory}} +test open-14.3 {POSIX open access modes: WRONLY} { + catch {exec rm -f test3} + string tolower [list [catch {open test3 WRONLY} msg] $msg] +} {1 {couldn't open "test3": no such file or directory}} +test open-14.4 {POSIX open access modes: WRONLY} { + exec echo xyzzy > test3 + set f [open test3 WRONLY] + puts -nonewline $f "ab" + seek $f 0 current + set x [list [catch {gets $f} msg] $msg] + close $f + lappend x [exec cat test3] + + # The regsub is needed to avoid false errors if the file + # number varies from system to system. + + regsub {"file."} $x {"file"} x + set x +} {1 {"file" wasn't opened for reading} abzzy} +test open-14.5 {POSIX open access modes: RDWR} { + catch {exec rm -f test3} + string tolower [list [catch {open test3 RDWR} msg] $msg] +} {1 {couldn't open "test3": no such file or directory}} +test open-14.6 {POSIX open access modes: RDWR} { + exec echo xyzzy > test3 + set f [open test3 RDWR] + puts -nonewline $f "ab" + seek $f 0 current + set x [gets $f] + close $f + lappend x [exec cat test3] +} {zzy abzzy} +test open-14.7 {POSIX open access modes: CREAT} { + catch {exec rm -f test3} + set f [open test3 {WRONLY CREAT} 0600] + file stat test3 stats + set x [format "0%o" [expr $stats(mode)&0777]] + puts $f "line 1" + close $f + lappend x [exec cat test3] +} {0600 {line 1}} +if $atBerkeley { + test open-14.8 {POSIX open access modes: CREAT} { + catch {exec rm -f test3} + set f [open test3 {WRONLY CREAT}] + close $f + file stat test3 stats + format "0%o" [expr $stats(mode)&0777] + } 0664 +} +test open-14.9 {POSIX open access modes: CREAT} { + exec echo xyzzy > test3 + set f [open test3 {WRONLY CREAT}] + puts -nonewline $f "ab" + close $f + exec cat test3 +} abzzy +test open-14.10 {POSIX open access modes: APPEND} { + exec echo xyzzy > test3 + set f [open test3 {WRONLY APPEND}] + puts $f "new line" + seek $f 0 + puts $f "abc" + close $f + exec cat test3 +} {xyzzy +new line +abc} +test open-14.11 {POSIX open access modes: EXCL} { + exec echo xyzzy > test3 + set msg [list [catch {open test3 {WRONLY CREAT EXCL}} msg] $msg] + regsub " already " $msg " " msg + string tolower $msg +} {1 {couldn't open "test3": file exists}} +test open-14.12 {POSIX open access modes: EXCL} { + catch {exec rm -f test3} + set x [catch {set f [open test3 {WRONLY CREAT EXCL}]}] + puts $f "A test line" + close $f + lappend x [exec cat test3] +} {0 {A test line}} +test open-14.13 {POSIX open access modes: TRUNC} { + exec echo xyzzy > test3 + set f [open test3 {WRONLY TRUNC}] + puts $f abc + close $f + exec cat test3 +} {abc} +if $atBerkeley { + test open-14.14 {POSIX open access modes: NOCTTY} { + catch {exec rm -f test3} + list [catch {open test3 {WRONLY NOCTTY CREAT}} msg] $msg + } {1 {access mode "NOCTTY" not supported by this system}} + test open-14.15 {POSIX open access modes: NONBLOCK} { + catch {exec rm -f test3} + set f [open test3 {WRONLY NONBLOCK CREAT}] + puts $f "NONBLOCK test" + close $f + exec cat test3 + } {NONBLOCK test} +} +test open-14.16 {POSIX open access modes: errors} { + concat [catch {open test3 "FOO \{BAR BAZ"} msg] $msg\n$errorInfo +} "1 unmatched open brace in list +unmatched open brace in list + while processing open access modes \"FOO {BAR BAZ\" + invoked from within +\"open test3 \"FOO \\{BAR BAZ\"\"" +test open-14.17 {POSIX open access modes: errors} { + list [catch {open test3 {FOO BAR BAZ}} msg] $msg +} {1 {invalid access mode "FOO": must be RDONLY, WRONLY, RDWR, APPEND, CREAT EXCL, NOCTTY, NONBLOCK, or TRUNC}} +test open-14.18 {POSIX open access modes: errors} { + list [catch {open test3 {TRUNC CREAT}} msg] $msg +} {1 {access mode must include either RDONLY, WRONLY, or RDWR}} + +catch {exec rm -f test1 test2 test3} +concat {} diff --git a/vendor/x11iraf/obm/Tcl/tests/parse.test b/vendor/x11iraf/obm/Tcl/tests/parse.test new file mode 100644 index 00000000..fde51011 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/tests/parse.test @@ -0,0 +1,429 @@ +# Commands covered: set (plus basic command syntax) +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1991-1993 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. +# +# $Header: /user6/ouster/tcl/tests/RCS/parse.test,v 1.24 93/07/28 13:07:14 ouster Exp $ (Berkeley) + +if {[string compare test [info procs test]] == 1} then {source defs} + +proc fourArgs {a b c d} { + global arg1 arg2 arg3 arg4 + set arg1 $a + set arg2 $b + set arg3 $c + set arg4 $d +} + +proc getArgs args { + global argv + set argv $args +} + +# Basic argument parsing. + +test parse-1.1 {basic argument parsing} { + set arg1 {} + fourArgs a b c d + list $arg1 $arg2 $arg3 $arg4 +} {a b c d} +test parse-1.2 {basic argument parsing} { + set arg1 {} + eval "fourArgs 123\v4\f56\r7890" + list $arg1 $arg2 $arg3 $arg4 +} {123 4 56 7890} + +# Quotes. + +test parse-2.1 {quotes and variable-substitution} { + getArgs "a b c" d + set argv +} {{a b c} d} +test parse-2.2 {quotes and variable-substitution} { + set a 101 + getArgs "a$a b c" + set argv +} {{a101 b c}} +test parse-2.3 {quotes and variable-substitution} { + set argv "xy[format xabc]" + set argv +} {xyxabc} +test parse-2.4 {quotes and variable-substitution} { + set argv "xy\t" + set argv +} xy\t +test parse-2.5 {quotes and variable-substitution} { + set argv "a b c +d e f" + set argv +} a\ b\tc\nd\ e\ f +test parse-2.6 {quotes and variable-substitution} { + set argv a"bcd"e + set argv +} {a"bcd"e} + +# Braces. + +test parse-3.1 {braces} { + getArgs {a b c} d + set argv +} "{a b c} d" +test parse-3.2 {braces} { + set a 101 + set argv {a$a b c} + set b [string index $argv 1] + set b +} {$} +test parse-3.3 {braces} { + set argv {a[format xyz] b} + string length $argv +} 15 +test parse-3.4 {braces} { + set argv {a\nb\}} + string length $argv +} 6 +test parse-3.5 {braces} { + set argv {{{{}}}} + set argv +} "{{{}}}" +test parse-3.6 {braces} { + set argv a{{}}b + set argv +} "a{{}}b" +test parse-3.7 {braces} { + set a [format "last]"] + set a +} {last]} + +# Command substitution. + +test parse-4.1 {command substitution} { + set a [format xyz] + set a +} xyz +test parse-4.2 {command substitution} { + set a a[format xyz]b[format q] + set a +} axyzbq +test parse-4.3 {command substitution} { + set a a[ +set b 22; +format %s $b + +]b + set a +} a22b + +# Variable substitution. + +test parse-5.1 {variable substitution} { + set a 123 + set b $a + set b +} 123 +test parse-5.2 {variable substitution} { + set a 345 + set b x$a.b + set b +} x345.b +test parse-5.3 {variable substitution} { + set _123z xx + set b $_123z^ + set b +} xx^ +test parse-5.4 {variable substitution} { + set a 78 + set b a${a}b + set b +} a78b +test parse-5.5 {variable substitution} {catch {$_non_existent_} msg} 1 +test parse-5.6 {variable substitution} { + catch {$_non_existent_} msg + set msg +} {can't read "_non_existent_": no such variable} +test parse-5.7 {array variable substitution} { + catch {unset a} + set a(xyz) 123 + set b $a(xyz)foo + set b +} 123foo +test parse-5.8 {array variable substitution} { + catch {unset a} + set "a(x y z)" 123 + set b $a(x y z)foo + set b +} 123foo +test parse-5.9 {array variable substitution} { + catch {unset a}; catch {unset qqq} + set "a(x y z)" qqq + set $a([format x]\ y [format z]) foo + set qqq +} foo +test parse-5.10 {array variable substitution} { + catch {unset a} + list [catch {set b $a(22)} msg] $msg +} {1 {can't read "a(22)": no such variable}} +test parse-5.11 {array variable substitution} { + set b a$! + set b +} {a$!} +test parse-5.12 {array variable substitution} { + set b a$() + set b +} {a$()} +catch {unset a} +test parse-5.13 {array variable substitution} { + catch {unset a} + set long {This is a very long variable, long enough to cause storage \ + allocation to occur in Tcl_ParseVar. If that storage isn't getting \ + freed up correctly, then a core leak will occur when this test is \ + run. This text is probably beginning to sound like drivel, but I've \ + run out of things to say and I need more characters still.} + set a($long) 777 + set b $a($long) + list $b [array names a] +} {777 {{This is a very long variable, long enough to cause storage \ + allocation to occur in Tcl_ParseVar. If that storage isn't getting \ + freed up correctly, then a core leak will occur when this test is \ + run. This text is probably beginning to sound like drivel, but I've \ + run out of things to say and I need more characters still.}}} +test parse-5.14 {array variable substitution} { + catch {unset a}; catch {unset b}; catch {unset a1} + set a1(22) foo + set a(foo) bar + set b $a($a1(22)) + set b +} bar +catch {unset a}; catch {unset a1} + +# Backslash substitution. + +set errNum 1 +proc bsCheck {char num} { + global errNum + test parse-6.$errNum {backslash substitution} { + scan $char %c value + set value + } $num + set errNum [expr $errNum+1] +} + +bsCheck \b 8 +bsCheck \e 101 +bsCheck \f 12 +bsCheck \n 10 +bsCheck \r 13 +bsCheck \t 9 +bsCheck \v 11 +bsCheck \{ 123 +bsCheck \} 125 +bsCheck \[ 91 +bsCheck \] 93 +bsCheck \$ 36 +bsCheck \ 32 +bsCheck \; 59 +bsCheck \\ 92 +bsCheck \Ca 67 +bsCheck \Ma 77 +bsCheck \CMa 67 +bsCheck \8a 8 +bsCheck \14 12 +bsCheck \141 97 +bsCheck \340 224 +bsCheck b\0 98 +bsCheck \x 120 +bsCheck \xa 10 +bsCheck \x41 65 +bsCheck \x541 65 + +test parse-7.1 {backslash substitution} { + set a "\a\c\n\]\}" + string length $a +} 5 +test parse-7.2 {backslash substitution} { + set a {\a\c\n\]\}} + string length $a +} 10 +test parse-7.3 {backslash substitution} { + set a "abc\ +def" + set a +} {abc def} +test parse-7.4 {backslash substitution} { + set a {abc\ +def} + set a +} {abc def} +test parse-7.5 {backslash substitution} { + set msg {} + set a xxx + set error [catch {if {24 < \ + 35} {set a 22} {set \ + a 33}} msg] + list $error $msg $a +} {0 22 22} +test parse-7.6 {backslash substitution} { + eval "concat abc\\" +} "abc\\" +test parse-7.7 {backslash substitution} { + eval "concat \\\na" +} "a" +test parse-7.8 {backslash substitution} { + eval "concat x\\\n \na" +} "x a" +test parse-7.9 {backslash substitution} { + eval "concat \\x" +} "x" +test parse-7.10 {backslash substitution} { + eval "list a b\\\nc d" +} {a b c d} + +# Semi-colon. + +test parse-8.1 {semi-colons} { + set b 0 + getArgs a;set b 2 + set argv +} a +test parse-8.2 {semi-colons} { + set b 0 + getArgs a;set b 2 + set b +} 2 +test parse-8.3 {semi-colons} { + getArgs a b ; set b 1 + set argv +} {a b} +test parse-8.4 {semi-colons} { + getArgs a b ; set b 1 + set b +} 1 + +# The following checks are to ensure that the interpreter's result +# gets re-initialized by Tcl_Eval in all the right places. + +test parse-9.1 {result initialization} {concat abc} abc +test parse-9.2 {result initialization} {concat abc; proc foo {} {}} {} +test parse-9.3 {result initialization} {concat abc; proc foo {} $a} {} +test parse-9.4 {result initialization} {proc foo {} [concat abc]} {} +test parse-9.5 {result initialization} {concat abc; } abc +test parse-9.6 {result initialization} { + eval { + concat abc +}} abc +test parse-9.7 {result initialization} {} {} +test parse-9.8 {result initialization} {concat abc; ; ;} abc + +# Syntax errors. + +test parse-10.1 {syntax errors} {catch "set a \{bcd" msg} 1 +test parse-10.2 {syntax errors} { + catch "set a \{bcd" msg + set msg +} {missing close-brace} +test parse-10.3 {syntax errors} {catch {set a "bcd} msg} 1 +test parse-10.4 {syntax errors} { + catch {set a "bcd} msg + set msg +} {missing "} +test parse-10.5 {syntax errors} {catch {set a "bcd"xy} msg} 1 +test parse-10.6 {syntax errors} { + catch {set a "bcd"xy} msg + set msg +} {extra characters after close-quote} +test parse-10.7 {syntax errors} {catch "set a {bcd}xy" msg} 1 +test parse-10.8 {syntax errors} { + catch "set a {bcd}xy" msg + set msg +} {extra characters after close-brace} +test parse-10.9 {syntax errors} {catch {set a [format abc} msg} 1 +test parse-10.10 {syntax errors} { + catch {set a [format abc} msg + set msg +} {missing close-bracket} +test parse-10.11 {syntax errors} {catch gorp-a-lot msg} 1 +test parse-10.12 {syntax errors} { + catch gorp-a-lot msg + set msg +} {invalid command name: "gorp-a-lot"} +test parse-10.13 {syntax errors} { + set a [concat {a}\ + {b}] + set a +} {a b} +test parse-10.14 {syntax errors} {catch "concat \{a\}\\\n{b}" msg} 1 +test parse-10.15 {syntax errors} { + catch "concat \{a\}\\\n{b}" msg + set msg +} {extra characters after close-brace} + +# Long values (stressing storage management) + +set a {1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH} + +test parse-11.1 {long values} { + string length $a +} 214 +test parse-11.2 {long values} { + llength $a +} 43 +test parse-1a1.3 {long values} { + set b "1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH" + set b +} $a +test parse-11.4 {long values} { + set b "$a" + set b +} $a +test parse-11.5 {long values} { + set b [set a] + set b +} $a +test parse-11.6 {long values} { + set b [concat 1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH] + string length $b +} 214 +test parse-11.7 {long values} { + set b [concat 1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH] + llength $b +} 43 +test parse-11.8 {long values} { + set b +} $a +test parse-11.9 {long values} { + set a [concat 0000 1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH IIII JJJJ KKKK LLLL MMMM NNNN OOOO PPPP QQQQ RRRR SSSS TTTT UUUU VVVV WWWW XXXX YYYY ZZZZ] + llength $a +} 62 +set i 0 +foreach j [concat 0000 1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH IIII JJJJ KKKK LLLL MMMM NNNN OOOO PPPP QQQQ RRRR SSSS TTTT UUUU VVVV WWWW XXXX YYYY ZZZZ] { + set test [string index 0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ $i] + set test $test$test$test$test + set i [expr $i+1] + test parse-11.10 {long values} { + set j + } $test +} +test parse-11.10 {test buffer overflow in backslashes in braces} { + expr {"a" == {xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyy\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101}} +} 0 diff --git a/vendor/x11iraf/obm/Tcl/tests/pid.test b/vendor/x11iraf/obm/Tcl/tests/pid.test new file mode 100644 index 00000000..b6023870 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/tests/pid.test @@ -0,0 +1,58 @@ +# Commands covered: pid +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1991-1993 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. +# +# $Header: /user6/ouster/tcl/tests/RCS/pid.test,v 1.1 93/05/15 16:06:39 ouster Exp $ (Berkeley) + +if {[string compare test [info procs test]] == 1} then {source defs} + +catch {exec rm -f test1} + +test open-1.1 {pid command} { + regexp {^[0-9]+$} [pid] +} 1 +test open-1.2 {pid command} { + set f [open {| echo foo | cat > /dev/null} w] + set pids [pid $f] + close $f + list [llength $pids] [regexp {^[0-9]+$} [lindex $pids 0]] \ + [regexp {^[0-9]+$} [lindex $pids 1]] \ + [expr {[lindex $pids 0] == [lindex $pids 1]}] +} {2 1 1 0} +test open-1.3 {pid command} { + set f [open test1 w] + set pids [pid $f] + close $f + set pids +} {} +test open-1.4 {pid command} { + list [catch {pid a b} msg] $msg +} {1 {wrong # args: should be "pid ?fileId?"}} +test open-1.5 {pid command} { + list [catch {pid gorp} msg] $msg +} {1 {bad file identifier "gorp"}} + +catch {exec rm -f test1} +concat {} diff --git a/vendor/x11iraf/obm/Tcl/tests/proc.test b/vendor/x11iraf/obm/Tcl/tests/proc.test new file mode 100644 index 00000000..f321b761 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/tests/proc.test @@ -0,0 +1,450 @@ +# Commands covered: proc, return, global +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1991-1993 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. +# +# $Header: /user6/ouster/tcl/tests/RCS/proc.test,v 1.15 93/08/03 16:10:28 ouster Exp $ (Berkeley) + +if {[string compare test [info procs test]] == 1} then {source defs} + +proc tproc {} {return a; return b} +test proc-1.1 {simple procedure call and return} {tproc} a +proc tproc x { + set x [expr $x+1] + return $x +} +test proc-1.2 {simple procedure call and return} {tproc 2} 3 +test proc-1.3 {simple procedure call and return} { + proc tproc {} {return foo} +} {} +test proc-1.4 {simple procedure call and return} { + proc tproc {} {return} + tproc +} {} + +test proc-2.1 {local and global variables} { + proc tproc x { + set x [expr $x+1] + return $x + } + set x 42 + list [tproc 6] $x +} {7 42} +test proc-2.2 {local and global variables} { + proc tproc x { + set y [expr $x+1] + return $y + } + set y 18 + list [tproc 6] $y +} {7 18} +test proc-2.3 {local and global variables} { + proc tproc x { + global y + set y [expr $x+1] + return $y + } + set y 189 + list [tproc 6] $y +} {7 7} +test proc-2.4 {local and global variables} { + proc tproc x { + global y + return [expr $x+$y] + } + set y 189 + list [tproc 6] $y +} {195 189} +catch {unset _undefined_} +test proc-2.5 {local and global variables} { + proc tproc x { + global _undefined_ + return $_undefined_ + } + list [catch {tproc xxx} msg] $msg +} {1 {can't read "_undefined_": no such variable}} +test proc-2.6 {local and global variables} { + set a 114 + set b 115 + global a b + list $a $b +} {114 115} + +proc do {cmd} {eval $cmd} +test proc-3.1 {local and global arrays} { + catch {unset a} + set a(0) 22 + list [catch {do {global a; set a(0)}} msg] $msg +} {0 22} +test proc-3.2 {local and global arrays} { + catch {unset a} + set a(x) 22 + list [catch {do {global a; set a(x) newValue}} msg] $msg $a(x) +} {0 newValue newValue} +test proc-3.3 {local and global arrays} { + catch {unset a} + set a(x) 22 + set a(y) 33 + list [catch {do {global a; unset a(y)}; array names a} msg] $msg +} {0 x} +test proc-3.4 {local and global arrays} { + catch {unset a} + set a(x) 22 + set a(y) 33 + list [catch {do {global a; unset a; info exists a}} msg] $msg \ + [info exists a] +} {0 0 0} +test proc-3.5 {local and global arrays} { + catch {unset a} + set a(x) 22 + set a(y) 33 + list [catch {do {global a; unset a(y); array names a}} msg] $msg +} {0 x} +catch {unset a} +test proc-3.6 {local and global arrays} { + catch {unset a} + set a(x) 22 + set a(y) 33 + do {global a; do {global a; unset a}; set a(z) 22} + list [catch {array names a} msg] $msg +} {0 z} +test proc-3.7 {local and global arrays} { + proc t1 {args} {global info; set info 1} + catch {unset a} + set info {} + do {global a; trace var a(1) w t1} + set a(1) 44 + set info +} 1 +test proc-3.8 {local and global arrays} { + proc t1 {args} {global info; set info 1} + catch {unset a} + trace var a(1) w t1 + set info {} + do {global a; trace vdelete a(1) w t1} + set a(1) 44 + set info +} {} +test proc-3.9 {local and global arrays} { + proc t1 {args} {global info; set info 1} + catch {unset a} + trace var a(1) w t1 + do {global a; trace vinfo a(1)} +} {{w t1}} +catch {unset a} + +test proc-3.1 {arguments and defaults} { + proc tproc {x y z} { + return [list $x $y $z] + } + tproc 11 12 13 +} {11 12 13} +test proc-3.2 {arguments and defaults} { + proc tproc {x y z} { + return [list $x $y $z] + } + list [catch {tproc 11 12} msg] $msg +} {1 {no value given for parameter "z" to "tproc"}} +test proc-3.3 {arguments and defaults} { + proc tproc {x y z} { + return [list $x $y $z] + } + list [catch {tproc 11 12 13 14} msg] $msg +} {1 {called "tproc" with too many arguments}} +test proc-3.4 {arguments and defaults} { + proc tproc {x {y y-default} {z z-default}} { + return [list $x $y $z] + } + tproc 11 12 13 +} {11 12 13} +test proc-3.5 {arguments and defaults} { + proc tproc {x {y y-default} {z z-default}} { + return [list $x $y $z] + } + tproc 11 12 +} {11 12 z-default} +test proc-3.6 {arguments and defaults} { + proc tproc {x {y y-default} {z z-default}} { + return [list $x $y $z] + } + tproc 11 +} {11 y-default z-default} +test proc-3.7 {arguments and defaults} { + proc tproc {x {y y-default} {z z-default}} { + return [list $x $y $z] + } + list [catch {tproc} msg] $msg +} {1 {no value given for parameter "x" to "tproc"}} +test proc-3.8 {arguments and defaults} { + list [catch { + proc tproc {x {y y-default} z} { + return [list $x $y $z] + } + tproc 2 3 + } msg] $msg +} {1 {no value given for parameter "z" to "tproc"}} +test proc-3.9 {arguments and defaults} { + proc tproc {x {y y-default} args} { + return [list $x $y $args] + } + tproc 2 3 4 5 +} {2 3 {4 5}} +test proc-3.10 {arguments and defaults} { + proc tproc {x {y y-default} args} { + return [list $x $y $args] + } + tproc 2 3 +} {2 3 {}} +test proc-3.11 {arguments and defaults} { + proc tproc {x {y y-default} args} { + return [list $x $y $args] + } + tproc 2 +} {2 y-default {}} +test proc-3.12 {arguments and defaults} { + proc tproc {x {y y-default} args} { + return [list $x $y $args] + } + list [catch {tproc} msg] $msg +} {1 {no value given for parameter "x" to "tproc"}} + +test proc-4.1 {variable numbers of arguments} { + proc tproc args {return $args} + tproc +} {} +test proc-4.2 {variable numbers of arguments} { + proc tproc args {return $args} + tproc 1 2 3 4 5 6 7 8 +} {1 2 3 4 5 6 7 8} +test proc-4.3 {variable numbers of arguments} { + proc tproc args {return $args} + tproc 1 {2 3} {4 {5 6} {{{7}}}} 8 +} {1 {2 3} {4 {5 6} {{{7}}}} 8} +test proc-4.4 {variable numbers of arguments} { + proc tproc {x y args} {return $args} + tproc 1 2 3 4 5 6 7 +} {3 4 5 6 7} +test proc-4.5 {variable numbers of arguments} { + proc tproc {x y args} {return $args} + tproc 1 2 +} {} +test proc-4.6 {variable numbers of arguments} { + proc tproc {x missing args} {return $args} + list [catch {tproc 1} msg] $msg +} {1 {no value given for parameter "missing" to "tproc"}} + +test proc-5.1 {error conditions} { + list [catch {proc} msg] $msg +} {1 {wrong # args: should be "proc name args body"}} +test proc-5.2 {error conditions} { + list [catch {proc tproc b} msg] $msg +} {1 {wrong # args: should be "proc name args body"}} +test proc-5.3 {error conditions} { + list [catch {proc tproc b c d e} msg] $msg +} {1 {wrong # args: should be "proc name args body"}} +test proc-5.4 {error conditions} { + list [catch {proc tproc \{xyz {return foo}} msg] $msg +} {1 {unmatched open brace in list}} +test proc-5.5 {error conditions} { + list [catch {proc tproc {{} y} {return foo}} msg] $msg +} {1 {procedure "tproc" has argument with no name}} +test proc-5.6 {error conditions} { + list [catch {proc tproc {{} y} {return foo}} msg] $msg +} {1 {procedure "tproc" has argument with no name}} +test proc-5.7 {error conditions} { + list [catch {proc tproc {{x 1 2} y} {return foo}} msg] $msg +} {1 {too many fields in argument specifier "x 1 2"}} +test proc-5.8 {error conditions} { + catch {return} +} 2 +test proc-5.9 {error conditions} { + list [catch {global} msg] $msg +} {1 {wrong # args: should be "global varName ?varName ...?"}} +proc tproc {} { + set a 22 + global a +} +test proc-5.10 {error conditions} { + list [catch {tproc} msg] $msg +} {1 {variable "a" already exists}} +test proc-5.11 {error conditions} { + catch {rename tproc {}} + catch { + proc tproc {x {} z} {return foo} + } + list [catch {tproc 1} msg] $msg +} {1 {invalid command name: "tproc"}} +test proc-5.12 {error conditions} { + proc tproc {} { + set a 22 + error "error in procedure" + return + } + list [catch tproc msg] $msg +} {1 {error in procedure}} +test proc-5.13 {error conditions} { + proc tproc {} { + set a 22 + error "error in procedure" + return + } + catch tproc msg + set errorInfo +} {error in procedure + while executing +"error "error in procedure"" + (procedure "tproc" line 3) + invoked from within +"tproc"} +test proc-5.14 {error conditions} { + proc tproc {} { + set a 22 + break + return + } + catch tproc msg + set errorInfo +} {invoked "break" outside of a loop + while executing +"tproc"} +test proc-5.15 {error conditions} { + proc tproc {} { + set a 22 + continue + return + } + catch tproc msg + set errorInfo +} {invoked "continue" outside of a loop + while executing +"tproc"} + +# The tests below will really only be useful when run under Purify or +# some other system that can detect accesses to freed memory... + +test proc-6.1 {procedure that redefines itself} { + proc tproc {} { + proc tproc {} { + return 44 + } + return 45 + } + tproc +} 45 +test proc-6.2 {procedure that deletes itself} { + proc tproc {} { + rename tproc {} + return 45 + } + tproc +} 45 + +proc tproc code { + return -code $code abc +} +test proc-7.1 {return with special completion code} { + list [catch {tproc ok} msg] $msg +} {0 abc} +test proc-7.2 {return with special completion code} { + list [catch {tproc error} msg] $msg $errorInfo $errorCode +} {1 abc {abc + while executing +"tproc error"} NONE} +test proc-7.3 {return with special completion code} { + list [catch {tproc return} msg] $msg +} {2 abc} +test proc-7.4 {return with special completion code} { + list [catch {tproc break} msg] $msg +} {3 abc} +test proc-7.5 {return with special completion code} { + list [catch {tproc continue} msg] $msg +} {4 abc} +test proc-7.6 {return with special completion code} { + list [catch {tproc -14} msg] $msg +} {-14 abc} +test proc-7.7 {return with special completion code} { + list [catch {tproc gorp} msg] $msg +} {1 {bad completion code "gorp": must be ok, error, return, break, continue, or an integer}} +test proc-7.8 {return with special completion code} { + list [catch {tproc 10b} msg] $msg +} {1 {bad completion code "10b": must be ok, error, return, break, continue, or an integer}} +test proc-7.9 {return with special completion code} { + proc tproc2 {} { + tproc return + } + list [catch tproc2 msg] $msg +} {0 abc} +test proc-7.10 {return with special completion code} { + proc tproc2 {} { + return -code error + } + list [catch tproc2 msg] $msg +} {1 {}} +test proc-7.11 {return with special completion code} { + proc tproc2 {} { + global errorCode errorInfo + catch {open _bad_file_name r} msg + return -code error -errorinfo $errorInfo -errorcode $errorCode $msg + } + string tolower [list [catch tproc2 msg] $msg $errorInfo $errorCode] +} {1 {couldn't open "_bad_file_name": no such file or directory} {couldn't open "_bad_file_name": no such file or directory + while executing +"open _bad_file_name r" + invoked from within +"tproc2"} {posix enoent {no such file or directory}}} +test proc-7.12 {return with special completion code} { + proc tproc2 {} { + global errorCode errorInfo + catch {open _bad_file_name r} msg + return -code error -errorcode $errorCode $msg + } + string tolower [list [catch tproc2 msg] $msg $errorInfo $errorCode] +} {1 {couldn't open "_bad_file_name": no such file or directory} {couldn't open "_bad_file_name": no such file or directory + while executing +"tproc2"} {posix enoent {no such file or directory}}} +test proc-7.13 {return with special completion code} { + proc tproc2 {} { + global errorCode errorInfo + catch {open _bad_file_name r} msg + return -code error -errorinfo $errorInfo $msg + } + string tolower [list [catch tproc2 msg] $msg $errorInfo $errorCode] +} {1 {couldn't open "_bad_file_name": no such file or directory} {couldn't open "_bad_file_name": no such file or directory + while executing +"open _bad_file_name r" + invoked from within +"tproc2"} none} +test proc-7.14 {return with special completion code} { + proc tproc2 {} { + global errorCode errorInfo + catch {open _bad_file_name r} msg + return -code error $msg + } + string tolower [list [catch tproc2 msg] $msg $errorInfo $errorCode] +} {1 {couldn't open "_bad_file_name": no such file or directory} {couldn't open "_bad_file_name": no such file or directory + while executing +"tproc2"} none} +test proc-7.14 {return with special completion code} { + list [catch {return -badOption foo message} msg] $msg +} {1 {bad option "-badOption: must be -code, -errorcode, or -errorinfo}} diff --git a/vendor/x11iraf/obm/Tcl/tests/regexp.test b/vendor/x11iraf/obm/Tcl/tests/regexp.test new file mode 100644 index 00000000..5f0bc7ce --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/tests/regexp.test @@ -0,0 +1,324 @@ +# Commands covered: regexp, regsub +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1991-1993 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. +# +# $Header: /user6/ouster/tcl/tests/RCS/regexp.test,v 1.13 93/10/14 14:53:21 ouster Exp $ (Berkeley) + +if {[string compare test [info procs test]] == 1} then {source defs} + +catch {unset foo} +test regexp-1.1 {basic regexp operation} { + regexp ab*c abbbc +} 1 +test regexp-1.2 {basic regexp operation} { + regexp ab*c ac +} 1 +test regexp-1.3 {basic regexp operation} { + regexp ab*c ab +} 0 +test regexp-1.4 {basic regexp operation} { + regexp -- -gorp abc-gorpxxx +} 1 + +test regexp-2.1 {getting substrings back from regexp} { + set foo {} + list [regexp ab*c abbbbc foo] $foo +} {1 abbbbc} +test regexp-2.2 {getting substrings back from regexp} { + set foo {} + set f2 {} + list [regexp a(b*)c abbbbc foo f2] $foo $f2 +} {1 abbbbc bbbb} +test regexp-2.3 {getting substrings back from regexp} { + set foo {} + set f2 {} + list [regexp a(b*)(c) abbbbc foo f2] $foo $f2 +} {1 abbbbc bbbb} +test regexp-2.4 {getting substrings back from regexp} { + set foo {} + set f2 {} + set f3 {} + list [regexp a(b*)(c) abbbbc foo f2 f3] $foo $f2 $f3 +} {1 abbbbc bbbb c} +test regexp-2.5 {getting substrings back from regexp} { + set foo {}; set f1 {}; set f2 {}; set f3 {}; set f4 {}; set f5 {}; + set f6 {}; set f7 {}; set f8 {}; set f9 {} + list [regexp (1*)(2*)(3*)(4*)(5*)(6*)(7*)(8*)(9*) 12223345556789999 \ + foo f1 f2 f3 f4 f5 f6 f7 f8 f9] $foo $f1 $f2 $f3 $f4 $f5 \ + $f6 $f7 $f8 $f9 +} {1 12223345556789999 1 222 33 4 555 6 7 8 9999} +test regexp-2.6 {getting substrings back from regexp} { + set foo 2; set f2 2; set f3 2; set f4 2 + list [regexp (a)(b)? xay foo f2 f3 f4] $foo $f2 $f3 $f4 +} {1 a a {} {}} +test regexp-2.7 {getting substrings back from regexp} { + set foo 1; set f2 1; set f3 1; set f4 1 + list [regexp (a)(b)?(c) xacy foo f2 f3 f4] $foo $f2 $f3 $f4 +} {1 ac a {} c} + +test regexp-3.1 {-indices option to regexp} { + set foo {} + list [regexp -indices ab*c abbbbc foo] $foo +} {1 {0 5}} +test regexp-3.2 {-indices option to regexp} { + set foo {} + set f2 {} + list [regexp -indices a(b*)c abbbbc foo f2] $foo $f2 +} {1 {0 5} {1 4}} +test regexp-3.3 {-indices option to regexp} { + set foo {} + set f2 {} + list [regexp -indices a(b*)(c) abbbbc foo f2] $foo $f2 +} {1 {0 5} {1 4}} +test regexp-3.4 {-indices option to regexp} { + set foo {} + set f2 {} + set f3 {} + list [regexp -indices a(b*)(c) abbbbc foo f2 f3] $foo $f2 $f3 +} {1 {0 5} {1 4} {5 5}} +test regexp-3.5 {-indices option to regexp} { + set foo {}; set f1 {}; set f2 {}; set f3 {}; set f4 {}; set f5 {}; + set f6 {}; set f7 {}; set f8 {}; set f9 {} + list [regexp -indices (1*)(2*)(3*)(4*)(5*)(6*)(7*)(8*)(9*) \ + 12223345556789999 \ + foo f1 f2 f3 f4 f5 f6 f7 f8 f9] $foo $f1 $f2 $f3 $f4 $f5 \ + $f6 $f7 $f8 $f9 +} {1 {0 16} {0 0} {1 3} {4 5} {6 6} {7 9} {10 10} {11 11} {12 12} {13 16}} +test regexp-3.6 {getting substrings back from regexp} { + set foo 2; set f2 2; set f3 2; set f4 2 + list [regexp -indices (a)(b)? xay foo f2 f3 f4] $foo $f2 $f3 $f4 +} {1 {1 1} {1 1} {-1 -1} {-1 -1}} +test regexp-3.7 {getting substrings back from regexp} { + set foo 1; set f2 1; set f3 1; set f4 1 + list [regexp -indices (a)(b)?(c) xacy foo f2 f3 f4] $foo $f2 $f3 $f4 +} {1 {1 2} {1 1} {-1 -1} {2 2}} + +test regexp-4.1 {-nocase option to regexp} { + regexp -nocase foo abcFOo +} 1 +test regexp-4.2 {-nocase option to regexp} { + set f1 22 + set f2 33 + set f3 44 + list [regexp -nocase {a(b*)([xy]*)z} aBbbxYXxxZ22 f1 f2 f3] $f1 $f2 $f3 +} {1 aBbbxYXxxZ Bbb xYXxx} +test regexp-4.3 {-nocase option to regexp} { + regexp -nocase FOo abcFOo +} 1 +set x abcdefghijklmnopqrstuvwxyz1234567890 +set x $x$x$x$x$x$x$x$x$x$x$x$x +test regexp-4.4 {case conversion in regsub} { + list [regexp -nocase $x $x foo] $foo +} "1 $x" +unset x + +test regexp-5.1 {exercise cache of compiled expressions} { + regexp .*a b + regexp .*b c + regexp .*c d + regexp .*d e + regexp .*e f + regexp .*a bbba +} 1 +test regexp-5.2 {exercise cache of compiled expressions} { + regexp .*a b + regexp .*b c + regexp .*c d + regexp .*d e + regexp .*e f + regexp .*b xxxb +} 1 +test regexp-5.3 {exercise cache of compiled expressions} { + regexp .*a b + regexp .*b c + regexp .*c d + regexp .*d e + regexp .*e f + regexp .*c yyyc +} 1 +test regexp-5.4 {exercise cache of compiled expressions} { + regexp .*a b + regexp .*b c + regexp .*c d + regexp .*d e + regexp .*e f + regexp .*d 1d +} 1 +test regexp-5.5 {exercise cache of compiled expressions} { + regexp .*a b + regexp .*b c + regexp .*c d + regexp .*d e + regexp .*e f + regexp .*e xe +} 1 + +test regexp-6.1 {regexp errors} { + list [catch {regexp a} msg] $msg +} {1 {wrong # args: should be "regexp ?switches? exp string ?matchVar? ?subMatchVar subMatchVar ...?"}} +test regexp-6.2 {regexp errors} { + list [catch {regexp -nocase a} msg] $msg +} {1 {wrong # args: should be "regexp ?switches? exp string ?matchVar? ?subMatchVar subMatchVar ...?"}} +test regexp-6.3 {regexp errors} { + list [catch {regexp -gorp a} msg] $msg +} {1 {bad switch "-gorp": must be -indices, -nocase, or --}} +test regexp-6.4 {regexp errors} { + list [catch {regexp a( b} msg] $msg +} {1 {couldn't compile regular expression pattern: unmatched ()}} +test regexp-6.5 {regexp errors} { + list [catch {regexp a( b} msg] $msg +} {1 {couldn't compile regular expression pattern: unmatched ()}} +test regexp-6.6 {regexp errors} { + list [catch {regexp a a f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1} msg] $msg +} {1 {too many substring variables}} +test regexp-6.7 {regexp errors} { + set f1 44 + list [catch {regexp abc abc f1(f2)} msg] $msg +} {1 {couldn't set variable "f1(f2)"}} + +test regexp-7.1 {basic regsub operation} { + list [regsub aa+ xaxaaaxaa 111&222 foo] $foo +} {1 xax111aaa222xaa} +test regexp-7.2 {basic regsub operation} { + list [regsub aa+ aaaxaa &111 foo] $foo +} {1 aaa111xaa} +test regexp-7.3 {basic regsub operation} { + list [regsub aa+ xaxaaa 111& foo] $foo +} {1 xax111aaa} +test regexp-7.4 {basic regsub operation} { + list [regsub aa+ aaa 11&2&333 foo] $foo +} {1 11aaa2aaa333} +test regexp-7.5 {basic regsub operation} { + list [regsub aa+ xaxaaaxaa &2&333 foo] $foo +} {1 xaxaaa2aaa333xaa} +test regexp-7.6 {basic regsub operation} { + list [regsub aa+ xaxaaaxaa 1&22& foo] $foo +} {1 xax1aaa22aaaxaa} +test regexp-7.7 {basic regsub operation} { + list [regsub a(a+) xaxaaaxaa {1\122\1} foo] $foo +} {1 xax1aa22aaxaa} +test regexp-7.8 {basic regsub operation} { + list [regsub a(a+) xaxaaaxaa {1\\\122\1} foo] $foo +} "1 {xax1\\aa22aaxaa}" +test regexp-7.9 {basic regsub operation} { + list [regsub a(a+) xaxaaaxaa {1\\122\1} foo] $foo +} "1 {xax1\\122aaxaa}" +test regexp-7.10 {basic regsub operation} { + list [regsub a(a+) xaxaaaxaa {1\\&\1} foo] $foo +} "1 {xax1\\aaaaaxaa}" +test regexp-7.11 {basic regsub operation} { + list [regsub a(a+) xaxaaaxaa {1\&\1} foo] $foo +} {1 xax1&aaxaa} +test regexp-7.12 {basic regsub operation} { + list [regsub a(a+) xaxaaaxaa {\1\1\1\1&&} foo] $foo +} {1 xaxaaaaaaaaaaaaaaxaa} +test regexp-7.13 {basic regsub operation} { + set foo xxx + list [regsub abc xyz 111 foo] $foo +} {0 xyz} +test regexp-7.14 {basic regsub operation} { + set foo xxx + list [regsub ^ xyz "111 " foo] $foo +} {1 {111 xyz}} +test regexp-7.15 {basic regsub operation} { + set foo xxx + list [regsub -- -foo abc-foodef "111 " foo] $foo +} {1 {abc111 def}} +test regexp-7.16 {basic regsub operation} { + set foo xxx + list [regsub x "" y foo] $foo +} {0 {}} + +test regexp-8.1 {case conversion in regsub} { + list [regsub -nocase a(a+) xaAAaAAay & foo] $foo +} {1 xaAAaAAay} +test regexp-8.2 {case conversion in regsub} { + list [regsub -nocase a(a+) xaAAaAAay & foo] $foo +} {1 xaAAaAAay} +test regexp-8.3 {case conversion in regsub} { + set foo 123 + list [regsub a(a+) xaAAaAAay & foo] $foo +} {0 xaAAaAAay} +test regexp-8.4 {case conversion in regsub} { + set foo 123 + list [regsub -nocase a CaDE b foo] $foo +} {1 CbDE} +test regexp-8.5 {case conversion in regsub} { + set foo 123 + list [regsub -nocase XYZ CxYzD b foo] $foo +} {1 CbD} +test regexp-8.6 {case conversion in regsub} { + set x abcdefghijklmnopqrstuvwxyz1234567890 + set x $x$x$x$x$x$x$x$x$x$x$x$x + set foo 123 + list [regsub -nocase $x $x b foo] $foo +} {1 b} + +test regexp-9.1 {-all option to regsub} { + set foo 86 + list [regsub -all x+ axxxbxxcxdx |&| foo] $foo +} {1 a|xxx|b|xx|c|x|d|x|} +test regexp-9.2 {-all option to regsub} { + set foo 86 + list [regsub -nocase -all x+ aXxXbxxcXdx |&| foo] $foo +} {1 a|XxX|b|xx|c|X|d|x|} +test regexp-9.3 {-all option to regsub} { + set foo 86 + list [regsub x+ axxxbxxcxdx |&| foo] $foo +} {1 a|xxx|bxxcxdx} +test regexp-9.4 {-all option to regsub} { + set foo 86 + list [regsub -all bc axxxbxxcxdx |&| foo] $foo +} {0 axxxbxxcxdx} +test regexp-9.5 {-all option to regsub} { + set foo xxx + list [regsub -all node "node node more" yy foo] $foo +} {1 {yy yy more}} +test regexp-9.6 {-all option to regsub} { + set foo xxx + list [regsub -all ^ xxx 123 foo] $foo +} {1 123xxx} + +test regexp-10.1 {regsub errors} { + list [catch {regsub a b c} msg] $msg +} {1 {wrong # args: should be "regsub ?switches? exp string subSpec varName"}} +test regexp-10.2 {regsub errors} { + list [catch {regsub -nocase a b c} msg] $msg +} {1 {wrong # args: should be "regsub ?switches? exp string subSpec varName"}} +test regexp-10.3 {regsub errors} { + list [catch {regsub -nocase -all a b c} msg] $msg +} {1 {wrong # args: should be "regsub ?switches? exp string subSpec varName"}} +test regexp-10.4 {regsub errors} { + list [catch {regsub a b c d e f} msg] $msg +} {1 {wrong # args: should be "regsub ?switches? exp string subSpec varName"}} +test regexp-10.5 {regsub errors} { + list [catch {regsub -gorp a b c} msg] $msg +} {1 {bad switch "-gorp": must be -all, -nocase, or --}} +test regexp-10.6 {regsub errors} { + list [catch {regsub -nocase a( b c d} msg] $msg +} {1 {couldn't compile regular expression pattern: unmatched ()}} +test regexp-10.7 {regsub errors} { + list [catch {regsub -nocase aaa aaa xxx f1(f2)} msg] $msg +} {1 {couldn't set variable "f1(f2)"}} diff --git a/vendor/x11iraf/obm/Tcl/tests/rename.test b/vendor/x11iraf/obm/Tcl/tests/rename.test new file mode 100644 index 00000000..c5c8d922 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/tests/rename.test @@ -0,0 +1,78 @@ +# Commands covered: rename +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1991-1993 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. +# +# $Header: /user6/ouster/tcl/tests/RCS/rename.test,v 1.5 93/02/06 15:54:23 ouster Exp $ (Berkeley) + +if {[string compare test [info procs test]] == 1} then {source defs} + +catch {rename r2 {}} +proc r1 {} {return "procedure r1"} +rename r1 r2 +test rename-1.1 {simple renaming} { + r2 +} {procedure r1} +test rename-1.2 {simple renaming} { + list [catch r1 msg] $msg +} {1 {invalid command name: "r1"}} +rename r2 {} +test rename-1.3 {simple renaming} { + list [catch r2 msg] $msg +} {1 {invalid command name: "r2"}} + +# The test below is tricky because it renames a built-in command. +# It's possible that the test procedure uses this command, so must +# restore the command before calling test again. + +rename list l.new +set a [catch list msg1] +set b [l.new a b c] +rename l.new list +set c [catch l.new msg2] +set d [list 111 222] +test 2.1 {renaming built-in command} { + list $a $msg1 $b $c $msg2 $d +} {1 {invalid command name: "list"} {a b c} 1 {invalid command name: "l.new"} {111 222}} + +test rename-3.1 {error conditions} { + list [catch {rename r1} msg] $msg $errorCode +} {1 {wrong # args: should be "rename oldName newName"} NONE} +test rename-3.2 {error conditions} { + list [catch {rename r1 r2 r3} msg] $msg $errorCode +} {1 {wrong # args: should be "rename oldName newName"} NONE} +test rename-3.3 {error conditions} { + proc r1 {} {} + proc r2 {} {} + list [catch {rename r1 r2} msg] $msg +} {1 {can't rename to "r2": command already exists}} +test rename-3.4 {error conditions} { + catch {rename r1 {}} + catch {rename r2 {}} + list [catch {rename r1 r2} msg] $msg +} {1 {can't rename "r1": command doesn't exist}} +test rename-3.5 {error conditions} { + catch {rename _non_existent_command {}} + list [catch {rename _non_existent_command {}} msg] $msg +} {1 {can't delete "_non_existent_command": command doesn't exist}} diff --git a/vendor/x11iraf/obm/Tcl/tests/scan.test b/vendor/x11iraf/obm/Tcl/tests/scan.test new file mode 100644 index 00000000..c0219d5f --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/tests/scan.test @@ -0,0 +1,276 @@ +# Commands covered: scan +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1991-1993 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. +# +# $Header: /user6/ouster/tcl/tests/RCS/scan.test,v 1.17 93/10/07 10:39:35 ouster Exp $ (Berkeley) + +if {[string compare test [info procs test]] == 1} then {source defs} + +test scan-1.1 {integer scanning} { + set a {}; set b {}; set c {}; set d {} + list [scan "-20 1476 \n33 0" "%d %d %d %d" a b c d] $a $b $c $d +} {4 -20 1476 33 0} +test scan-1.2 {integer scanning} { + set a {}; set b {}; set c {} + list [scan "-45 16 7890 +10" "%2d %*d %10d %d" a b c] $a $b $c +} {3 -4 16 7890} +test scan-1.3 {integer scanning} { + set a {}; set b {}; set c {}; set d {} + list [scan "-45 16 +10 987" "%ld %d %ld %d" a b c d] $a $b $c $d +} {4 -45 16 10 987} +test scan-1.4 {integer scanning} { + set a {}; set b {}; set c {}; set d {} + list [scan "14 1ab 62 10" "%d %x %lo %x" a b c d] $a $b $c $d +} {4 14 427 50 16} +test scan-1.5 {integer scanning} { + set a {}; set b {}; set c {}; set d {} + list [scan "12345670 1234567890ab cdefg" "%o %o %x %lx" a b c d] \ + $a $b $c $d +} {4 2739128 342391 561323 52719} +test scan-1.6 {integer scanning} { + set a {}; set b {}; set c {}; set d {} + list [scan "ab123-24642" "%2x %3x %3o %2o" a b c d] $a $b $c $d +} {4 171 291 -20 52} +test scan-1.7 {integer scanning} { + set a {}; set b {} + list [scan "1234567 234 567 " "%*3x %x %*o %4o" a b] $a $b +} {2 17767 375} +test scan-1.8 {integer scanning} { + set a {}; set b {} + list [scan "a 1234" "%d %d" a b] $a $b +} {0 {} {}} +test scan-1.9 {integer scanning} { + set a {}; set b {}; set c {}; set d {}; + list [scan "12345678" "%2d %2d %2ld %2d" a b c d] $a $b $c $d +} {4 12 34 56 78} +test scan-1.10 {integer scanning} { + set a {}; set b {}; set c {}; set d {} + list [scan "1 2 " "%hd %d %d %d" a b c d] $a $b $c $d +} {2 1 2 {} {}} +if $atBerkeley { + test scan-1.11 {integer scanning} { + set a {}; set b {}; + list [scan "4294967280 4294967280" "%u %d" a b] $a $b + } {2 4294967280 -16} +} + +test scan-2.1 {floating-point scanning} { + set a {}; set b {}; set c {}; set d {} + list [scan "2.1 -3.0e8 .99962 a" "%f%g%e%f" a b c d] $a $b $c $d +} {3 2.1 -3e+08 0.99962 {}} +test scan-2.2 {floating-point scanning} { + set a {}; set b {}; set c {}; set d {} + list [scan "-1.2345 +8.2 9" "%3e %3lf %f %f" a b c d] $a $b $c $d +} {4 -1.0 234.0 5.0 8.2} +test scan-2.3 {floating-point scanning} { + set a {}; set b {}; set c {} + list [scan "1e00004 332E-4 3e+4" "%Lf %*2e %f %f" a b c] $a $c +} {3 10000.0 30000.0} +if $atBerkeley { + test scan-2.4 {floating-point scanning} { + set a {}; set b {}; set c {} + list [scan "1. 47.6 2.e2 3.e-" "%f %*f %f %f" a b c] $a $b $c + } {3 1.0 200.0 3.0} + test scan-2.5 {floating-point scanning} { + set a {}; set b {} + list [scan "1.eabc" "%f %x" a b] $a $b + } {2 1.0 2748} +} +test scan-2.6 {floating-point scanning} { + set a {}; set b {}; set c {}; set d {} + list [scan "4.6 99999.7 876.43e-1 118" "%f %f %f %e" a b c d] $a $b $c $d +} {4 4.6 99999.7 87.643 118.0} +test scan-2.7 {floating-point scanning} { + set a {}; set b {}; set c {}; set d {} + list [scan "1.2345 697.0e-3 124 .00005" "%f %e %f %e" a b c d] $a $b $c $d +} {4 1.2345 0.697 124.0 5e-05} +test scan-2.8 {floating-point scanning} { + set a {}; set b {}; set c {}; set d {} + list [scan "4.6abc" "%f %f %f %f" a b c d] $a $b $c $d +} {1 4.6 {} {} {}} +test scan-2.9 {floating-point scanning} { + set a {}; set b {}; set c {}; set d {} + list [scan "4.6 5.2" "%f %f %f %f" a b c d] $a $b $c $d +} {2 4.6 5.2 {} {}} + +test scan-3.1 {string and character scanning} { + set a {}; set b {}; set c {}; set d {} + list [scan "abc defghijk dum " "%s %3s %20s %s" a b c d] $a $b $c $d +} {4 abc def ghijk dum} +test scan-3.2 {string and character scanning} { + set a {}; set b {}; set c {}; set d {} + list [scan "a bcdef" "%c%c%1s %s" a b c d] $a $b $c $d +} {4 97 32 b cdef} +test scan-3.3 {string and character scanning} { + set a {}; set b {}; set c {} + list [scan "123456 test " "%*c%*s %s %s %s" a b c] $a $b $c +} {1 test {} {}} +test scan-3.4 {string and character scanning} { + set a {}; set b {}; set c {}; set d + list [scan "ababcd01234 f 123450" {%4[abcd] %4[abcd] %[^abcdef] %[^0]} a b c d] $a $b $c $d +} {4 abab cd {01234 } {f 12345}} +test scan-3.5 {string and character scanning} { + set a {}; set b {}; set c {} + list [scan "aaaaaabc aaabcdefg + + XYZQR" {%*4[a] %s %*4[a]%s%*4[ +]%c} a b c] $a $b $c +} {3 aabc bcdefg 43} + +test scan-4.1 {error conditions} { + catch {scan a} +} 1 +test scan-4.2 {error conditions} { + catch {scan a} msg + set msg +} {wrong # args: should be "scan string format ?varName varName ...?"} +test scan-4.3 {error conditions} { + catch {scan "1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21" "%d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d" a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20 a21} +} 1 +test scan-4.4 {error conditions} { + catch {scan "1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21" "%d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d" a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20 a21} msg + set msg +} {too many fields to scan} +test scan-4.5 {error conditions} { + list [catch {scan a %D} msg] $msg +} {1 {bad scan conversion character "D"}} +test scan-4.6 {error conditions} { + list [catch {scan a %O} msg] $msg +} {1 {bad scan conversion character "O"}} +test scan-4.7 {error conditions} { + list [catch {scan a %X} msg] $msg +} {1 {bad scan conversion character "X"}} +test scan-4.8 {error conditions} { + list [catch {scan a %F} msg] $msg +} {1 {bad scan conversion character "F"}} +test scan-4.9 {error conditions} { + list [catch {scan a %E} msg] $msg +} {1 {bad scan conversion character "E"}} +test scan-4.10 {error conditions} { + list [catch {scan a "%d %d" a} msg] $msg +} {1 {different numbers of variable names and field specifiers}} +test scan-4.11 {error conditions} { + list [catch {scan a "%d %d" a b c} msg] $msg +} {1 {different numbers of variable names and field specifiers}} +test scan-4.12 {error conditions} { + set a {}; set b {}; set c {}; set d {} + list [expr {[scan " a" " a %d %d %d %d" a b c d] <= 0}] $a $b $c $d +} {1 {} {} {} {}} +test scan-4.13 {error conditions} { + set a {}; set b {}; set c {}; set d {} + list [scan "1 2" "%d %d %d %d" a b c d] $a $b $c $d +} {2 1 2 {} {}} +test scan-4.14 {error conditions} { + catch {unset a} + set a(0) 44 + list [catch {scan 44 %d a} msg] $msg +} {1 {couldn't set variable "a"}} +test scan-4.15 {error conditions} { + catch {unset a} + set a(0) 44 + list [catch {scan 44 %c a} msg] $msg +} {1 {couldn't set variable "a"}} +test scan-4.16 {error conditions} { + catch {unset a} + set a(0) 44 + list [catch {scan 44 %s a} msg] $msg +} {1 {couldn't set variable "a"}} +test scan-4.17 {error conditions} { + catch {unset a} + set a(0) 44 + list [catch {scan 44 %f a} msg] $msg +} {1 {couldn't set variable "a"}} +test scan-4.18 {error conditions} { + catch {unset a} + set a(0) 44 + list [catch {scan 44 %f a} msg] $msg +} {1 {couldn't set variable "a"}} +catch {unset a} +test scan-4.19 {error conditions} { + list [catch {scan 44 %2c a} msg] $msg +} {1 {field width may not be specified in %c conversion}} + +test scan-5.1 {lots of arguments} { + scan "10 20 30 40 50 60 70 80 90 100 110 120 130 140 150 160 170 180 190 200" "%d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d" a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20 +} 20 +test scan-5.2 {lots of arguments} { + scan "10 20 30 40 50 60 70 80 90 100 110 120 130 140 150 160 170 180 190 200" "%d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d" a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20 + set a20 +} 200 + +test scan-6.1 {miscellaneous tests} { + set a {} + list [scan ab16c ab%dc a] $a +} {1 16} +test scan-6.2 {miscellaneous tests} { + set a {} + list [scan ax16c ab%dc a] $a +} {0 {}} +test scan-6.3 {miscellaneous tests} { + set a {} + list [catch {scan ab%c114 ab%%c%d a} msg] $msg $a +} {0 1 114} +test scan-6.4 {miscellaneous tests} { + set a {} + list [catch {scan ab%c14 ab%%c%d a} msg] $msg $a +} {0 1 14} +test scan-6.5 {miscellaneous tests} { + catch {unset tcl_precision} + set a {} + scan 1.111122223333 %f a + set a +} {1.11112} +test scan-6.6 {miscellaneous tests} { + set tcl_precision 10 + set a {} + scan 1.111122223333 %lf a + unset tcl_precision + set a +} {1.111122223} +test scan-6.7 {miscellaneous tests} { + set tcl_precision 10 + set a {} + scan 1.111122223333 %f a + unset tcl_precision + set a +} {1.111122223} + +test scan-7.1 {alignment in results array (TCL_ALIGN)} { + scan "123 13.6" "%s %f" a b + set b +} 13.6 +test scan-7.2 {alignment in results array (TCL_ALIGN)} { + scan "1234567 13.6" "%s %f" a b + set b +} 13.6 +test scan-7.3 {alignment in results array (TCL_ALIGN)} { + scan "12345678901 13.6" "%s %f" a b + set b +} 13.6 +test scan-7.4 {alignment in results array (TCL_ALIGN)} { + scan "123456789012345 13.6" "%s %f" a b + set b +} 13.6 +test scan-7.5 {alignment in results array (TCL_ALIGN)} { + scan "1234567890123456789 13.6" "%s %f" a b + set b +} 13.6 diff --git a/vendor/x11iraf/obm/Tcl/tests/set.test b/vendor/x11iraf/obm/Tcl/tests/set.test new file mode 100644 index 00000000..f8622e32 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/tests/set.test @@ -0,0 +1,584 @@ +# Commands covered: set, unset, array +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1991-1993 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. +# +# $Header: /user6/ouster/tcl/tests/RCS/set.test,v 1.12 93/07/21 09:18:48 ouster Exp $ (Berkeley) + +if {[string compare test [info procs test]] == 1} then {source defs} + +proc ignore args {} + +# Simple variable operations. + +catch {unset a} +test set-1.1 {basic variable setting and unsetting} { + set a 22 +} 22 +test set-1.2 {basic variable setting and unsetting} { + set a 123 + set a +} 123 +test set-1.3 {basic variable setting and unsetting} { + set a xxx + format %s $a +} xxx +test set-1.4 {basic variable setting and unsetting} { + set a 44 + unset a + list [catch {set a} msg] $msg +} {1 {can't read "a": no such variable}} + +# Basic array operations. + +catch {unset a} +set a(xyz) 2 +set a(44) 3 +set {a(a long name)} test +test set-2.1 {basic array operations} { + lsort [array names a] +} {44 {a long name} xyz} +test set-2.2 {basic array operations} { + set a(44) +} 3 +test set-2.3 {basic array operations} { + set a(xyz) +} 2 +test set-2.4 {basic array operations} { + set "a(a long name)" +} test +test set-2.5 {basic array operations} { + list [catch {set a(other)} msg] $msg +} {1 {can't read "a(other)": no such element in array}} +test set-2.6 {basic array operations} { + list [catch {set a} msg] $msg +} {1 {can't read "a": no such variable}} +test set-2.7 {basic array operations} { + format %s $a(44) +} 3 +test set-2.8 {basic array operations} { + format %s $a(a long name) +} test +unset a(44) +test set-2.9 {basic array operations} { + lsort [array names a] +} {{a long name} xyz} +test set-2.10 {basic array operations} { + catch {unset b} + list [catch {set b(123)} msg] $msg +} {1 {can't read "b(123)": no such variable}} +test set-2.11 {basic array operations} { + catch {unset b} + set b 44 + list [catch {set b(123)} msg] $msg +} {1 {can't read "b(123)": variable isn't array}} +test set-2.12 {basic array operations} { + list [catch {set a} msg] $msg +} {1 {can't read "a": no such variable}} +test set-2.13 {basic array operations} { + list [catch {set a 14} msg] $msg +} {1 {can't set "a": variable is array}} +unset a +test set-2.14 {basic array operations} { + list [catch {set a(xyz)} msg] $msg +} {1 {can't read "a(xyz)": no such variable}} + +# Test the set commands, and exercise the corner cases of the code +# that parses array references into two parts. + +test set-3.1 {set command} { + list [catch {set} msg] $msg +} {1 {wrong # args: should be "set varName ?newValue?"}} +test set-3.2 {set command} { + list [catch {set x y z} msg] $msg +} {1 {wrong # args: should be "set varName ?newValue?"}} +test set-3.3 {set command} { + catch {unset a} + list [catch {set a} msg] $msg +} {1 {can't read "a": no such variable}} +test set-3.4 {set command} { + catch {unset a} + set a(14) 83 + list [catch {set a 22} msg] $msg +} {1 {can't set "a": variable is array}} + +# Test the corner-cases of parsing array names, using set and unset. + +test set-4.1 {parsing array names} { + catch {unset a} + set a(()) 44 + list [catch {array names a} msg] $msg +} {0 ()} +test set-4.2 {parsing array names} { + catch {unset a a(abcd} + set a(abcd 33 + info exists a(abcd +} 1 +test set-4.3 {parsing array names} { + catch {unset a a(abcd} + set a(abcd 33 + list [catch {array names a} msg] $msg +} {1 {"a" isn't an array}} +test set-4.4 {parsing array names} { + catch {unset a abcd)} + set abcd) 33 + info exists abcd) +} 1 +test set-4.5 {parsing array names} { + set a(bcd yyy + catch {unset a} + list [catch {set a(bcd} msg] $msg +} {0 yyy} +test set-4.6 {parsing array names} { + catch {unset a} + set a 44 + list [catch {set a(bcd test} msg] $msg +} {0 test} + +# Errors in reading variables + +test set-5.1 {errors in reading variables} { + catch {unset a} + list [catch {set a} msg] $msg +} {1 {can't read "a": no such variable}} +test set-5.2 {errors in reading variables} { + catch {unset a} + set a 44 + list [catch {set a(18)} msg] $msg +} {1 {can't read "a(18)": variable isn't array}} +test set-5.3 {errors in reading variables} { + catch {unset a} + set a(6) 44 + list [catch {set a(18)} msg] $msg +} {1 {can't read "a(18)": no such element in array}} +test set-5.4 {errors in reading variables} { + catch {unset a} + set a(6) 44 + list [catch {set a} msg] $msg +} {1 {can't read "a": no such variable}} + +# Errors and other special cases in writing variables + +test set-6.1 {creating array during write} { + catch {unset a} + trace var a rwu ignore + list [catch {set a(14) 186} msg] $msg [array names a] +} {0 186 14} +test set-6.2 {errors in writing variables} { + catch {unset a} + set a xxx + list [catch {set a(14) 186} msg] $msg +} {1 {can't set "a(14)": variable isn't array}} +test set-6.3 {errors in writing variables} { + catch {unset a} + set a(100) yyy + list [catch {set a 2} msg] $msg +} {1 {can't set "a": variable is array}} +test set-6.4 {expanding variable size} { + catch {unset a} + list [set a short] [set a "longer name"] [set a "even longer name"] \ + [set a "a much much truly longer name"] +} {short {longer name} {even longer name} {a much much truly longer name}} + +# Unset command, Tcl_UnsetVar procedures + +test set-7.1 {unset command} { + catch {unset a}; catch {unset b}; catch {unset c}; catch {unset d} + set a 44 + set b 55 + set c 66 + set d 77 + unset a b c + list [catch {set a(0) 0}] [catch {set b(0) 0}] [catch {set c(0) 0}] \ + [catch {set d(0) 0}] +} {0 0 0 1} +test set-7.2 {unset command} { + list [catch {unset} msg] $msg +} {1 {wrong # args: should be "unset varName ?varName ...?"}} +test set-7.3 {unset command} { + catch {unset a} + list [catch {unset a} msg] $msg +} {1 {can't unset "a": no such variable}} +test set-7.4 {unset command} { + catch {unset a} + set a 44 + list [catch {unset a(14)} msg] $msg +} {1 {can't unset "a(14)": variable isn't array}} +test set-7.5 {unset command} { + catch {unset a} + set a(0) xx + list [catch {unset a(14)} msg] $msg +} {1 {can't unset "a(14)": no such element in array}} +test set-7.6 {unset command} { + catch {unset a}; catch {unset b}; catch {unset c} + set a foo + set c gorp + list [catch {unset a a a(14)} msg] $msg [info exists c] +} {1 {can't unset "a": no such variable} 1} +test set-7.7 {unsetting globals from within procedures} { + set y 0 + proc p1 {} { + global y + set z [p2] + return [list $z [catch {set y} msg] $msg] + } + proc p2 {} {global y; unset y; list [catch {set y} msg] $msg} + p1 +} {{1 {can't read "y": no such variable}} 1 {can't read "y": no such variable}} +test set-7.8 {unsetting globals from within procedures} { + set y 0 + proc p1 {} { + global y + p2 + return [list [catch {set y 44} msg] $msg] + } + proc p2 {} {global y; unset y} + concat [p1] [list [catch {set y} msg] $msg] +} {0 44 0 44} +test set-7.9 {unsetting globals from within procedures} { + set y 0 + proc p1 {} { + global y + unset y + return [list [catch {set y 55} msg] $msg] + } + concat [p1] [list [catch {set y} msg] $msg] +} {0 55 0 55} +test set-7.10 {unset command} { + catch {unset a} + set a(14) 22 + unset a(14) + list [catch {set a(14)} msg] $msg [catch {array names a} msg2] $msg2 +} {1 {can't read "a(14)": no such element in array} 0 {}} +test set-7.11 {unset command} { + catch {unset a} + set a(14) 22 + unset a + list [catch {set a(14)} msg] $msg [catch {array names a} msg2] $msg2 +} {1 {can't read "a(14)": no such variable} 1 {"a" isn't an array}} + +# Array command. + +test set-8.1 {array command} { + list [catch {array} msg] $msg +} {1 {wrong # args: should be "array option arrayName ?arg ...?"}} +test set-8.2 {array command} { + catch {unset a} + list [catch {array names a} msg] $msg +} {1 {"a" isn't an array}} +test set-8.3 {array command} { + catch {unset a} + set a 44 + list [catch {array names a} msg] $msg +} {1 {"a" isn't an array}} +test set-8.4 {array command} { + catch {unset a} + set a(22) 3 + list [catch {array gorp a} msg] $msg +} {1 {bad option "gorp": should be anymore, donesearch, names, nextelement, size, or startsearch}} +test set-8.5 {array command, names option} { + catch {unset a} + set a(22) 3 + list [catch {array names a 4} msg] $msg +} {1 {wrong # args: should be "array names arrayName"}} +test set-8.6 {array command, names option} { + catch {unset a} + set a(22) 3; set a(Textual_name) 44; set "a(name with spaces)" xxx + list [catch {lsort [array names a]} msg] $msg +} {0 {22 Textual_name {name with spaces}}} +test set-8.7 {array command, names option} { + catch {unset a} + set a(22) 3; set a(33) 44; + trace var a(xxx) w ignore + list [catch {lsort [array names a]} msg] $msg +} {0 {22 33}} +test set-8.8 {array command, names option} { + catch {unset a} + set a(22) 3; set a(33) 44; + trace var a(xxx) w ignore + set a(xxx) value + list [catch {lsort [array names a]} msg] $msg +} {0 {22 33 xxx}} +test set-8.9 {array command, size option} { + catch {unset a} + set a(22) 3 + list [catch {array size a 4} msg] $msg +} {1 {wrong # args: should be "array size arrayName"}} +test set-8.10 {array command, size option} { + catch {unset a} + set a(22) 3; set a(Textual_name) 44; set "a(name with spaces)" xxx + list [catch {array size a} msg] $msg +} {0 3} +test set-8.10 {array command, size option} { + catch {unset a} + set a(22) 3; set a(xx) 44; set a(y) xxx + unset a(22) a(y) a(xx) + list [catch {array size a} msg] $msg +} {0 0} +test set-8.11 {array command, size option} { + catch {unset a} + set a(22) 3; + trace var a(33) rwu ignore + list [catch {array size a} msg] $msg +} {0 1} + +test set-9.1 {ids for array enumeration} { + catch {unset a} + set a(a) 1 + list [array st a] [array st a] [array done a s-1-a; array st a] \ + [array done a s-2-a; array d a s-3-a; array start a] +} {s-1-a s-2-a s-3-a s-1-a} +test set-9.2 {array enumeration} { + catch {unset a} + set a(a) 1 + set a(b) 1 + set a(c) 1 + set x [array startsearch a] + list [array nextelement a $x] [array ne a $x] [array next a $x] \ + [array next a $x] [array next a $x] +} {a b c {} {}} +test set-9.3 {array enumeration} { + catch {unset a} + set a(a) 1 + set a(b) 1 + set a(c) 1 + set x [array startsearch a] + set y [array startsearch a] + set z [array startsearch a] + list [array nextelement a $x] [array ne a $x] \ + [array next a $y] [array next a $z] [array next a $y] \ + [array next a $z] [array next a $y] [array next a $z] \ + [array next a $y] [array next a $z] [array next a $x] \ + [array next a $x] +} {a b a a b b c c {} {} c {}} +test set-9.4 {array enumeration: stopping searches} { + catch {unset a} + set a(a) 1 + set a(b) 1 + set a(c) 1 + set x [array startsearch a] + set y [array startsearch a] + set z [array startsearch a] + list [array next a $x] [array next a $x] [array next a $y] \ + [array done a $z; array next a $x] \ + [array done a $x; array next a $y] [array next a $y] +} {a b a c b c} +test set-9.5 {array enumeration: stopping searches} { + catch {unset a} + set a(a) 1 + set x [array startsearch a] + array done a $x + list [catch {array next a $x} msg] $msg +} {1 {couldn't find search "s-1-a"}} +test set-9.6 {array enumeration: searches automatically stopped} { + catch {unset a} + set a(a) 1 + set x [array startsearch a] + set y [array startsearch a] + set a(b) 1 + list [catch {array next a $x} msg] $msg \ + [catch {array next a $y} msg2] $msg2 +} {1 {couldn't find search "s-1-a"} 1 {couldn't find search "s-2-a"}} +test set-9.7 {array enumeration: searches automatically stopped} { + catch {unset a} + set a(a) 1 + set x [array startsearch a] + set y [array startsearch a] + set a(a) 2 + list [catch {array next a $x} msg] $msg \ + [catch {array next a $y} msg2] $msg2 +} {0 a 0 a} +test set-9.8 {array enumeration: searches automatically stopped} { + catch {unset a} + set a(a) 1 + set a(c) 2 + set x [array startsearch a] + set y [array startsearch a] + catch {unset a(c)} + list [catch {array next a $x} msg] $msg \ + [catch {array next a $y} msg2] $msg2 +} {1 {couldn't find search "s-1-a"} 1 {couldn't find search "s-2-a"}} +test set-9.9 {array enumeration: searches automatically stopped} { + catch {unset a} + set a(a) 1 + set x [array startsearch a] + set y [array startsearch a] + catch {unset a(c)} + list [catch {array next a $x} msg] $msg \ + [catch {array next a $y} msg2] $msg2 +} {0 a 0 a} +test set-9.10 {array enumeration: searches automatically stopped} { + catch {unset a} + set a(a) 1 + set x [array startsearch a] + set y [array startsearch a] + trace var a(b) r {} + list [catch {array next a $x} msg] $msg \ + [catch {array next a $y} msg2] $msg2 +} {1 {couldn't find search "s-1-a"} 1 {couldn't find search "s-2-a"}} +test set-9.11 {array enumeration: searches automatically stopped} { + catch {unset a} + set a(a) 1 + set x [array startsearch a] + set y [array startsearch a] + trace var a(a) r {} + list [catch {array next a $x} msg] $msg \ + [catch {array next a $y} msg2] $msg2 +} {0 a 0 a} +test set-9.12 {array enumeration with traced undefined elements} { + catch {unset a} + set a(a) 1 + trace var a(b) r {} + set x [array startsearch a] + list [array next a $x] [array next a $x] +} {a {}} + +test set-10.1 {array enumeration errors} { + list [catch {array start} msg] $msg +} {1 {wrong # args: should be "array option arrayName ?arg ...?"}} +test set-10.2 {array enumeration errors} { + list [catch {array start a b} msg] $msg +} {1 {wrong # args: should be "array startsearch arrayName"}} +test set-10.3 {array enumeration errors} { + catch {unset a} + list [catch {array start a} msg] $msg +} {1 {"a" isn't an array}} +test set-10.4 {array enumeration errors} { + catch {unset a} + set a(a) 1 + set x [array startsearch a] + list [catch {array next a} msg] $msg +} {1 {wrong # args: should be "array nextelement arrayName searchId"}} +test set-10.5 {array enumeration errors} { + catch {unset a} + set a(a) 1 + set x [array startsearch a] + list [catch {array next a b c} msg] $msg +} {1 {wrong # args: should be "array nextelement arrayName searchId"}} +test set-10.6 {array enumeration errors} { + catch {unset a} + set a(a) 1 + set x [array startsearch a] + list [catch {array next a a-1-a} msg] $msg +} {1 {illegal search identifier "a-1-a"}} +test set-10.7 {array enumeration errors} { + catch {unset a} + set a(a) 1 + set x [array startsearch a] + list [catch {array next a sx1-a} msg] $msg +} {1 {illegal search identifier "sx1-a"}} +test set-10.8 {array enumeration errors} { + catch {unset a} + set a(a) 1 + set x [array startsearch a] + list [catch {array next a s--a} msg] $msg +} {1 {illegal search identifier "s--a"}} +test set-10.9 {array enumeration errors} { + catch {unset a} + set a(a) 1 + set x [array startsearch a] + list [catch {array next a s-1-b} msg] $msg +} {1 {search identifier "s-1-b" isn't for variable "a"}} +test set-10.10 {array enumeration errors} { + catch {unset a} + set a(a) 1 + set x [array startsearch a] + list [catch {array next a s-1ba} msg] $msg +} {1 {illegal search identifier "s-1ba"}} +test set-10.11 {array enumeration errors} { + catch {unset a} + set a(a) 1 + set x [array startsearch a] + list [catch {array next a s-2-a} msg] $msg +} {1 {couldn't find search "s-2-a"}} +test set-10.12 {array enumeration errors} { + list [catch {array done a} msg] $msg +} {1 {wrong # args: should be "array donesearch arrayName searchId"}} +test set-10.13 {array enumeration errors} { + list [catch {array done a b c} msg] $msg +} {1 {wrong # args: should be "array donesearch arrayName searchId"}} +test set-10.14 {array enumeration errors} { + list [catch {array done a b} msg] $msg +} {1 {illegal search identifier "b"}} +test set-10.15 {array enumeration errors} { + list [catch {array anymore a} msg] $msg +} {1 {wrong # args: should be "array anymore arrayName searchId"}} +test set-10.16 {array enumeration errors} { + list [catch {array any a b c} msg] $msg +} {1 {wrong # args: should be "array anymore arrayName searchId"}} +test set-10.17 {array enumeration errors} { + catch {unset a} + set a(0) 44 + list [catch {array any a bogus} msg] $msg +} {1 {illegal search identifier "bogus"}} + +# Array enumeration with "anymore" option + +test set-11.1 {array anymore option} { + catch {unset a} + set a(a) 1 + set a(b) 2 + set a(c) 3 + array startsearch a + list [array anymore a s-1-a] [array next a s-1-a] \ + [array anymore a s-1-a] [array next a s-1-a] \ + [array anymore a s-1-a] [array next a s-1-a] \ + [array anymore a s-1-a] [array next a s-1-a] +} {1 a 1 b 1 c 0 {}} +test set-11.2 {array anymore option} { + catch {unset a} + set a(a) 1 + set a(b) 2 + set a(c) 3 + array startsearch a + list [array next a s-1-a] [array next a s-1-a] \ + [array anymore a s-1-a] [array next a s-1-a] \ + [array next a s-1-a] [array anymore a s-1-a] +} {a b 1 c {} 0} + +# Special check to see that the value of a variable is handled correctly +# if it is returned as the result of a procedure (must not free the variable +# string while deleting the call frame). Errors will only be detected if +# a memory consistency checker such as Purify is being used. + +test set-12.1 {cleanup on procedure return} { + proc foo {} { + set x 12345 + } + foo +} 12345 +test set-12.2 {cleanup on procedure return} { + proc foo {} { + set x(1) 23456 + } + foo +} 23456 + +# Must delete variables when done, since these arrays get used as +# scalars by other tests. + +catch {unset a} +catch {unset b} +catch {unset c} +return "" diff --git a/vendor/x11iraf/obm/Tcl/tests/source.test b/vendor/x11iraf/obm/Tcl/tests/source.test new file mode 100644 index 00000000..4ad049a0 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/tests/source.test @@ -0,0 +1,95 @@ +# Commands covered: source +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1991-1993 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. +# +# $Header: /user6/ouster/tcl/tests/RCS/source.test,v 1.8 93/02/17 13:22:56 ouster Exp $ (Berkeley) + +if {[string compare test [info procs test]] == 1} then {source defs} + +test source-1.1 {source command} { + set x "old x value" + set y "old y value" + set z "old z value" + exec cat << { + set x 22 + set y 33 + set z 44 + } > source.file + source source.file + list $x $y $z +} {22 33 44} +test source-1.2 {source command} { + exec cat << {list result} > source.file + source source.file +} result + +test source-2.1 {source error conditions} { + list [catch {source} msg] $msg +} {1 {wrong # args: should be "source fileName"}} +test source-2.2 {source error conditions} { + list [catch {source a b} msg] $msg +} {1 {wrong # args: should be "source fileName"}} +test source-2.3 {source error conditions} { + exec cat << { + set x 146 + error "error in sourced file" + set y $x + } > source.file + list [catch {source source.file} msg] $msg $errorInfo +} {1 {error in sourced file} {error in sourced file + while executing +"error "error in sourced file"" + (file "source.file" line 3) + invoked from within +"source source.file"}} +test source-2.4 {source error conditions} { + exec cat << {break} > source.file + catch {source source.file} +} 3 +test source-2.5 {source error conditions} { + exec cat << {continue} > source.file + catch {source source.file} +} 4 +test source-2.6 {source error conditions} { + string tolower [list [catch {source _non_existent_} msg] $msg $errorCode] +} {1 {couldn't read file "_non_existent_": no such file or directory} {posix enoent {no such file or directory}}} + +test source-3.1 {return in middle of source file} { + exec cat << { + set x new-x + return allDone + set y new-y + } > source.file + set x old-x + set y old-y + set z [source source.file] + list $x $y $z +} {new-x old-y allDone} + +catch {exec rm source.file} + +# Generate null final value + +concat {} diff --git a/vendor/x11iraf/obm/Tcl/tests/split.test b/vendor/x11iraf/obm/Tcl/tests/split.test new file mode 100644 index 00000000..1e2a3d8b --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/tests/split.test @@ -0,0 +1,58 @@ +# Commands covered: split +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1991-1993 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. +# +# $Header: /user6/ouster/tcl/tests/RCS/split.test,v 1.6 93/10/11 09:05:58 ouster Exp $ (Berkeley) + +if {[string compare test [info procs test]] == 1} then {source defs} + +test split-1.1 {basic split commands} { + split "a\n b\t\r c\n " +} {a {} b {} {} c {} {}} +test split-1.2 {basic split commands} { + split "word 1xyzword 2zword 3" xyz +} {{word 1} {} {} {word 2} {word 3}} +test split-1.3 {basic split commands} { + split "12345" {} +} {1 2 3 4 5} +test split-1.4 {basic split commands} { + split "a\}b\[c\{\]\$" +} "a\\}b\\\[c\\{\\\]\\\$" +test split-1.5 {basic split commands} { + split {} {} +} {} +test split-1.6 {basic split commands} { + split {} +} {} +test split-1.7 {basic split commands} { + split { } +} {{} {} {} {}} + +test split-2.1 {split errors} { + list [catch split msg] $msg $errorCode +} {1 {wrong # args: should be "split string ?splitChars?"} NONE} +test split-2.2 {split errors} { + list [catch {split a b c} msg] $msg $errorCode +} {1 {wrong # args: should be "split string ?splitChars?"} NONE} diff --git a/vendor/x11iraf/obm/Tcl/tests/string.test b/vendor/x11iraf/obm/Tcl/tests/string.test new file mode 100644 index 00000000..e0bc44a6 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/tests/string.test @@ -0,0 +1,333 @@ +# Commands covered: string +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1991-1993 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. +# +# $Header: /user6/ouster/tcl/tests/RCS/string.test,v 1.7 93/02/06 15:54:24 ouster Exp $ (Berkeley) + +if {[string compare test [info procs test]] == 1} then {source defs} + +test string-1.1 {string compare} { + string compare abcde abdef +} -1 +test string-1.2 {string compare} { + string c abcde ABCDE +} 1 +test string-1.3 {string compare} { + string compare abcde abcde +} 0 +test string-1.4 {string compare} { + list [catch {string compare a} msg] $msg +} {1 {wrong # args: should be "string compare string1 string2"}} +test string-1.5 {string compare} { + list [catch {string compare a b c} msg] $msg +} {1 {wrong # args: should be "string compare string1 string2"}} + +test string-2.1 {string first} { + string first bq abcdefgbcefgbqrs +} 12 +test string-2.2 {string first} { + string fir bcd abcdefgbcefgbqrs +} 1 +test string-2.3 {string first} { + string f b abcdefgbcefgbqrs +} 1 +test string-2.4 {string first} { + string first xxx x123xx345xxx789xxx012 +} 9 +test string-2.5 {string first} { + list [catch {string first a} msg] $msg +} {1 {wrong # args: should be "string first string1 string2"}} +test string-2.6 {string first} { + list [catch {string first a b c} msg] $msg +} {1 {wrong # args: should be "string first string1 string2"}} + +test string-3.1 {string index} { + string index abcde 0 +} a +test string-3.2 {string index} { + string i abcde 4 +} e +test string-3.3 {string index} { + string index abcde 5 +} {} +test string-3.4 {string index} { + list [catch {string index abcde -10} msg] $msg +} {0 {}} +test string-3.5 {string index} { + list [catch {string index} msg] $msg +} {1 {wrong # args: should be "string index string charIndex"}} +test string-3.6 {string index} { + list [catch {string index a b c} msg] $msg +} {1 {wrong # args: should be "string index string charIndex"}} +test string-3.7 {string index} { + list [catch {string index a xyz} msg] $msg +} {1 {expected integer but got "xyz"}} + +test string-4.1 {string last} { + string la xxx xxxx123xx345x678 +} 1 +test string-4.2 {string last} { + string last xx xxxx123xx345x678 +} 7 +test string-4.3 {string last} { + string las x xxxx123xx345x678 +} 12 +test string-4.4 {string last} { + list [catch {string last a} msg] $msg +} {1 {wrong # args: should be "string last string1 string2"}} +test string-4.5 {string last} { + list [catch {string last a b c} msg] $msg +} {1 {wrong # args: should be "string last string1 string2"}} + +test string-5.1 {string length} { + string length "a little string" +} 15 +test string-5.2 {string length} { + string le "" +} 0 +test string-5.3 {string length} { + list [catch {string length} msg] $msg +} {1 {wrong # args: should be "string length string"}} +test string-5.4 {string length} { + list [catch {string length a b} msg] $msg +} {1 {wrong # args: should be "string length string"}} + +test string-6.1 {string match} { + string match abc abc +} 1 +test string-6.2 {string match} { + string m abc abd +} 0 +test string-6.3 {string match} { + string match ab*c abc +} 1 +test string-6.4 {string match} { + string match ab**c abc +} 1 +test string-6.5 {string match} { + string match ab* abcdef +} 1 +test string-6.6 {string match} { + string match *c abc +} 1 +test string-6.7 {string match} { + string match *3*6*9 0123456789 +} 1 +test string-6.8 {string match} { + string match *3*6*9 01234567890 +} 0 +test string-6.9 {string match} { + string match a?c abc +} 1 +test string-6.10 {string match} { + string match a??c abc +} 0 +test string-6.11 {string match} { + string match ?1??4???8? 0123456789 +} 1 +test string-6.12 {string match} { + string match {[abc]bc} abc +} 1 +test string-6.13 {string match} { + string match {a[abc]c} abc +} 1 +test string-6.14 {string match} { + string match {a[xyz]c} abc +} 0 +test string-6.15 {string match} { + string match {12[2-7]45} 12345 +} 1 +test string-6.16 {string match} { + string match {12[ab2-4cd]45} 12345 +} 1 +test string-6.17 {string match} { + string match {12[ab2-4cd]45} 12b45 +} 1 +test string-6.18 {string match} { + string match {12[ab2-4cd]45} 12d45 +} 1 +test string-6.19 {string match} { + string match {12[ab2-4cd]45} 12145 +} 0 +test string-6.20 {string match} { + string match {12[ab2-4cd]45} 12545 +} 0 +test string-6.21 {string match} { + string match {a\*b} a*b +} 1 +test string-6.22 {string match} { + string match {a\*b} ab +} 0 +test string-6.23 {string match} { + string match {a\*\?\[\]\\\x} "a*?\[\]\\x" +} 1 +test string-6.24 {string match} { + string match ** "" +} 1 +test string-6.25 {string match} { + string match *. "" +} 0 +test string-6.26 {string match} { + string match "" "" +} 1 +test string-6.27 {string match} { + list [catch {string match a} msg] $msg +} {1 {wrong # args: should be "string match pattern string"}} +test string-6.28 {string match} { + list [catch {string match a b c} msg] $msg +} {1 {wrong # args: should be "string match pattern string"}} + +test string-7.1 {string range} { + string range abcdefghijklmnop 2 14 +} {cdefghijklmno} +test string-7.2 {string range} { + string range abcdefghijklmnop 7 1000 +} {hijklmnop} +test string-7.3 {string range} { + string range abcdefghijklmnop 10 e +} {klmnop} +test string-7.4 {string range} { + string range abcdefghijklmnop 10 9 +} {} +test string-7.5 {string range} { + string range abcdefghijklmnop -3 2 +} {abc} +test string-7.6 {string range} { + string range abcdefghijklmnop -3 -2 +} {} +test string-7.7 {string range} { + string range abcdefghijklmnop 1000 1010 +} {} +test string-7.8 {string range} { + string range abcdefghijklmnop -100 end +} {abcdefghijklmnop} +test string-7.9 {string range} { + list [catch {string range} msg] $msg +} {1 {wrong # args: should be "string range string first last"}} +test string-7.10 {string range} { + list [catch {string range a 1} msg] $msg +} {1 {wrong # args: should be "string range string first last"}} +test string-7.11 {string range} { + list [catch {string range a 1 2 3} msg] $msg +} {1 {wrong # args: should be "string range string first last"}} +test string-7.12 {string range} { + list [catch {string range abc abc 1} msg] $msg +} {1 {expected integer but got "abc"}} +test string-7.13 {string range} { + list [catch {string range abc 1 eof} msg] $msg +} {1 {expected integer or "end" but got "eof"}} + +test string-8.1 {string trim} { + string trim " XYZ " +} {XYZ} +test string-8.2 {string trim} { + string trim "\t\nXYZ\t\n\r\n" +} {XYZ} +test string-8.3 {string trim} { + string trim " A XYZ A " +} {A XYZ A} +test string-8.4 {string trim} { + string trim "XXYYZZABC XXYYZZ" ZYX +} {ABC } +test string-8.5 {string trim} { + string trim " \t\r " +} {} +test string-8.6 {string trim} { + string trim {abcdefg} {} +} {abcdefg} +test string-8.7 {string trim} { + string trim {} +} {} +test string-8.8 {string trim} { + string trim ABC DEF +} {ABC} +test string-8.9 {string trim} { + list [catch {string trim} msg] $msg +} {1 {wrong # args: should be "string trim string ?chars?"}} +test string-8.10 {string trim} { + list [catch {string trim a b c} msg] $msg +} {1 {wrong # args: should be "string trim string ?chars?"}} + +test string-9.1 {string trimleft} { + string trimleft " XYZ " +} {XYZ } +test string-9.2 {string trimleft} { + list [catch {string triml} msg] $msg +} {1 {wrong # args: should be "string trimleft string ?chars?"}} + +test string-10.1 {string trimright} { + string trimright " XYZ " +} { XYZ} +test string-10.2 {string trimright} { + string trimright " " +} {} +test string-10.3 {string trimright} { + string trimright "" +} {} +test string-10.4 {string trimright errors} { + list [catch {string trimr} msg] $msg +} {1 {wrong # args: should be "string trimright string ?chars?"}} +test string-10.5 {string trimright errors} { + list [catch {string trimg a} msg] $msg +} {1 {bad option "trimg": should be compare, first, index, last, length, match, range, tolower, toupper, trim, trimleft, or trimright}} + +test string-11.1 {string tolower} { + string tolower ABCDeF +} {abcdef} +test string-11.2 {string tolower} { + string tolower "ABC XyZ" +} {abc xyz} +test string-11.3 {string tolower} { + string tolower {123#$&*()} +} {123#$&*()} +test string-11.4 {string tolower} { + list [catch {string tolower} msg] $msg +} {1 {wrong # args: should be "string tolower string"}} +test string-11.5 {string tolower} { + list [catch {string tolower a b} msg] $msg +} {1 {wrong # args: should be "string tolower string"}} + +test string-12.1 {string toupper} { + string toupper abCDEf +} {ABCDEF} +test string-12.2 {string toupper} { + string toupper "abc xYz" +} {ABC XYZ} +test string-12.3 {string toupper} { + string toupper {123#$&*()} +} {123#$&*()} +test string-12.4 {string toupper} { + list [catch {string toupper} msg] $msg +} {1 {wrong # args: should be "string toupper string"}} +test string-12.5 {string toupper} { + list [catch {string toupper a b} msg] $msg +} {1 {wrong # args: should be "string toupper string"}} + +test string-13.1 {error conditions} { + list [catch {string gorp a b} msg] $msg +} {1 {bad option "gorp": should be compare, first, index, last, length, match, range, tolower, toupper, trim, trimleft, or trimright}} +test string-13.2 {error conditions} { + list [catch {string} msg] $msg +} {1 {wrong # args: should be "string option arg ?arg ...?"}} diff --git a/vendor/x11iraf/obm/Tcl/tests/switch.test b/vendor/x11iraf/obm/Tcl/tests/switch.test new file mode 100644 index 00000000..dd2baa27 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/tests/switch.test @@ -0,0 +1,184 @@ +# Commands covered: switch +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1993 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. +# +# $Header: /user6/ouster/tcl/tests/RCS/switch.test,v 1.2 93/06/17 11:53:58 ouster Exp $ (Berkeley) + +if {[string compare test [info procs test]] == 1} then {source defs} + +test switch-1.1 {simple patterns} { + switch a a {format 1} b {format 2} c {format 3} default {format 4} +} 1 +test switch-1.2 {simple patterns} { + switch b a {format 1} b {format 2} c {format 3} default {format 4} +} 2 +test switch-1.3 {simple patterns} { + switch x a {format 1} b {format 2} c {format 3} default {format 4} +} 4 +test switch-1.4 {simple patterns} { + switch x a {format 1} b {format 2} c {format 3} +} {} +test switch-1.5 {simple pattern matches many times} { + switch b a {format 1} b {format 2} b {format 3} b {format 4} +} 2 +test switch-1.6 {simple patterns} { + switch default a {format 1} default {format 2} c {format 3} default {format 4} +} 2 +test switch-1.7 {simple patterns} { + switch x a {format 1} default {format 2} c {format 3} default {format 4} +} 4 + +test switch-2.1 {single-argument form for pattern/command pairs} { + switch b { + a {format 1} + b {format 2} + default {format 6} + } +} {2} +test switch-2.2 {single-argument form for pattern/command pairs} { + list [catch {switch z {a 2 b}} msg] $msg +} {1 {extra switch pattern with no body}} + +test switch-3.1 {-exact vs. -glob vs. -regexp} { + switch -exact aaaab { + ^a*b$ {concat regexp} + *b {concat glob} + aaaab {concat exact} + default {concat none} + } +} exact +test switch-3.2 {-exact vs. -glob vs. -regexp} { + switch -exact -regexp aaaab { + ^a*b$ {concat regexp} + *b {concat glob} + aaaab {concat exact} + default {concat none} + } +} regexp +test switch-3.3 {-exact vs. -glob vs. -regexp} { + switch -glob aaaab { + ^a*b$ {concat regexp} + *b {concat glob} + aaaab {concat exact} + default {concat none} + } +} glob +test switch-3.4 {-exact vs. -glob vs. -regexp} { + switch aaaab {^a*b$} {concat regexp} *b {concat glob} \ + aaaab {concat exact} default {concat none} +} exact +test switch-3.5 {-exact vs. -glob vs. -regexp} { + switch -- -glob { + ^g.*b$ {concat regexp} + -* {concat glob} + -glob {concat exact} + default {concat none} + } +} exact +test switch-3.6 {-exact vs. -glob vs. -regexp} { + list [catch {switch -foo a b c} msg] $msg +} {1 {bad option "-foo": should be -exact, -glob, -regexp, or --}} + +test switch-4.1 {error in executed command} { + list [catch {switch a a {error "Just a test"} default {format 1}} msg] \ + $msg $errorInfo +} {1 {Just a test} {Just a test + while executing +"error "Just a test"" + ("a" arm line 1) + invoked from within +"switch a a {error "Just a test"} default {format 1}"}} +test switch-4.2 {error: not enough args} { + list [catch {switch} msg] $msg +} {1 {wrong # args: should be "switch ?switches? string pattern body ... ?default body?"}} +test switch-4.3 {error: pattern with no body} { + list [catch {switch a b} msg] $msg +} {1 {extra switch pattern with no body}} +test switch-4.4 {error: pattern with no body} { + list [catch {switch a b {format 1} c} msg] $msg +} {1 {extra switch pattern with no body}} +test switch-4.5 {error in default command} { + list [catch {switch foo a {error switch1} b {error switch 3} \ + default {error switch2}} msg] $msg $errorInfo +} {1 switch2 {switch2 + while executing +"error switch2" + ("default" arm line 1) + invoked from within +"switch foo a {error switch1} b {error switch 3} default {error switch2}"}} + +test switch-5.1 {errors in -regexp matching} { + list [catch {switch -regexp aaaab { + *b {concat glob} + aaaab {concat exact} + default {concat none} + }} msg] $msg +} {1 {couldn't compile regular expression pattern: ?+* follows nothing}} + +test switch-6.1 {backslashes in patterns} { + switch -exact {\a\$\.\[} { + \a\$\.\[ {concat first} + \a\\$\.\\[ {concat second} + \\a\\$\\.\\[ {concat third} + {\a\\$\.\\[} {concat fourth} + {\\a\\$\\.\\[} {concat fifth} + default {concat none} + } +} third +test switch-6.2 {backslashes in patterns} { + switch -exact {\a\$\.\[} { + \a\$\.\[ {concat first} + {\a\$\.\[} {concat second} + {{\a\$\.\[}} {concat third} + default {concat none} + } +} second + +test switch-7.1 {"-" bodies} { + switch a { + a - + b - + c {concat 1} + default {concat 2} + } +} 1 +test switch-7.2 {"-" bodies} { + list [catch { + switch a { + a - + b - + c - + } + } msg] $msg +} {1 {no body specified for pattern "a"}} +test switch-7.3 {"-" bodies} { + list [catch { + switch a { + a - + b -foo + c - + } + } msg] $msg +} {1 {invalid command name: "-foo"}} diff --git a/vendor/x11iraf/obm/Tcl/tests/trace.test b/vendor/x11iraf/obm/Tcl/tests/trace.test new file mode 100644 index 00000000..02fc051c --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/tests/trace.test @@ -0,0 +1,914 @@ +# Commands covered: trace +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1991-1993 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. +# +# $Header: /user6/ouster/tcl/tests/RCS/trace.test,v 1.20 93/10/11 09:05:38 ouster Exp $ (Berkeley) + +if {[string compare test [info procs test]] == 1} then {source defs} + +proc traceScalar {name1 name2 op} { + global info + set info [list $name1 $name2 $op [catch {uplevel set $name1} msg] $msg] +} +proc traceArray {name1 name2 op} { + global info + set info [list $name1 $name2 $op [catch {uplevel set [set name1]($name2)} msg] $msg] +} +proc traceProc {name1 name2 op} { + global info + set info [concat $info [list $name1 $name2 $op]] +} +proc traceTag {tag args} { + global info + set info [concat $info $tag] +} +proc traceError {args} { + error "trace returned error" +} +proc traceCheck {cmd args} { + global info + set info [list [catch $cmd msg] $msg] +} +proc traceCrtElement {value name1 name2 op} { + uplevel set ${name1}($name2) $value +} + +# Read-tracing on variables + +test trace-1.1 {trace variable reads} { + catch {unset x} + set info {} + trace var x r traceScalar + list [catch {set x} msg] $msg $info +} {1 {can't read "x": no such variable} {x {} r 1 {can't read "x": no such variable}}} +test trace-1.2 {trace variable reads} { + catch {unset x} + set x 123 + set info {} + trace var x r traceScalar + list [catch {set x} msg] $msg $info +} {0 123 {x {} r 0 123}} +test trace-1.3 {trace variable reads} { + catch {unset x} + set info {} + trace var x r traceScalar + set x 123 + set info +} {} +test trace-1.4 {trace array element reads} { + catch {unset x} + set info {} + trace var x(2) r traceArray + list [catch {set x(2)} msg] $msg $info +} {1 {can't read "x(2)": no such element in array} {x 2 r 1 {can't read "x(2)": no such element in array}}} +test trace-1.5 {trace array element reads} { + catch {unset x} + set x(2) zzz + set info {} + trace var x(2) r traceArray + list [catch {set x(2)} msg] $msg $info +} {0 zzz {x 2 r 0 zzz}} +test trace-1.6 {trace reads on whole arrays} { + catch {unset x} + set info {} + trace var x r traceArray + list [catch {set x(2)} msg] $msg $info +} {1 {can't read "x(2)": no such variable} {}} +test trace-1.7 {trace reads on whole arrays} { + catch {unset x} + set x(2) zzz + set info {} + trace var x r traceArray + list [catch {set x(2)} msg] $msg $info +} {0 zzz {x 2 r 0 zzz}} +test trace-1.8 {trace variable reads} { + catch {unset x} + set x 444 + set info {} + trace var x r traceScalar + unset x + set info +} {} + +# Basic write-tracing on variables + +test trace-2.1 {trace variable writes} { + catch {unset x} + set info {} + trace var x w traceScalar + set x 123 + set info +} {x {} w 0 123} +test trace-2.2 {trace writes to array elements} { + catch {unset x} + set info {} + trace var x(33) w traceArray + set x(33) 444 + set info +} {x 33 w 0 444} +test trace-2.3 {trace writes on whole arrays} { + catch {unset x} + set info {} + trace var x w traceArray + set x(abc) qq + set info +} {x abc w 0 qq} +test trace-2.4 {trace variable writes} { + catch {unset x} + set x 1234 + set info {} + trace var x w traceScalar + set x + set info +} {} +test trace-2.5 {trace variable writes} { + catch {unset x} + set x 1234 + set info {} + trace var x w traceScalar + unset x + set info +} {} + +# Basic unset-tracing on variables + +test trace-3.1 {trace variable unsets} { + catch {unset x} + set info {} + trace var x u traceScalar + catch {unset x} + set info +} {x {} u 1 {can't read "x": no such variable}} +test trace-3.2 {variable mustn't exist during unset trace} { + catch {unset x} + set x 1234 + set info {} + trace var x u traceScalar + unset x + set info +} {x {} u 1 {can't read "x": no such variable}} +test trace-3.3 {unset traces mustn't be called during reads and writes} { + catch {unset x} + set info {} + trace var x u traceScalar + set x 44 + set x + set info +} {} +test trace-3.4 {trace unsets on array elements} { + catch {unset x} + set x(0) 18 + set info {} + trace var x(1) u traceArray + catch {unset x(1)} + set info +} {x 1 u 1 {can't read "x(1)": no such element in array}} +test trace-3.5 {trace unsets on array elements} { + catch {unset x} + set x(1) 18 + set info {} + trace var x(1) u traceArray + unset x(1) + set info +} {x 1 u 1 {can't read "x(1)": no such element in array}} +test trace-3.6 {trace unsets on array elements} { + catch {unset x} + set x(1) 18 + set info {} + trace var x(1) u traceArray + unset x + set info +} {x 1 u 1 {can't read "x(1)": no such variable}} +test trace-3.7 {trace unsets on whole arrays} { + catch {unset x} + set x(1) 18 + set info {} + trace var x u traceProc + catch {unset x(0)} + set info +} {} +test trace-3.8 {trace unsets on whole arrays} { + catch {unset x} + set x(1) 18 + set x(2) 144 + set x(3) 14 + set info {} + trace var x u traceProc + unset x(1) + set info +} {x 1 u} +test trace-3.9 {trace unsets on whole arrays} { + catch {unset x} + set x(1) 18 + set x(2) 144 + set x(3) 14 + set info {} + trace var x u traceProc + unset x + set info +} {x {} u} + +# Trace multiple trace types at once. + +test trace-4.1 {multiple ops traced at once} { + catch {unset x} + set info {} + trace var x rwu traceProc + catch {set x} + set x 22 + set x + set x 33 + unset x + set info +} {x {} r x {} w x {} r x {} w x {} u} +test trace-4.2 {multiple ops traced on array element} { + catch {unset x} + set info {} + trace var x(0) rwu traceProc + catch {set x(0)} + set x(0) 22 + set x(0) + set x(0) 33 + unset x(0) + unset x + set info +} {x 0 r x 0 w x 0 r x 0 w x 0 u} +test trace-4.3 {multiple ops traced on whole array} { + catch {unset x} + set info {} + trace var x rwu traceProc + catch {set x(0)} + set x(0) 22 + set x(0) + set x(0) 33 + unset x(0) + unset x + set info +} {x 0 w x 0 r x 0 w x 0 u x {} u} + +# Check order of invocation of traces + +test trace-5.1 {order of invocation of traces} { + catch {unset x} + set info {} + trace var x r "traceTag 1" + trace var x r "traceTag 2" + trace var x r "traceTag 3" + catch {set x} + set x 22 + set x + set info +} {3 2 1 3 2 1} +test trace-5.2 {order of invocation of traces} { + catch {unset x} + set x(0) 44 + set info {} + trace var x(0) r "traceTag 1" + trace var x(0) r "traceTag 2" + trace var x(0) r "traceTag 3" + set x(0) + set info +} {3 2 1} +test trace-5.3 {order of invocation of traces} { + catch {unset x} + set x(0) 44 + set info {} + trace var x(0) r "traceTag 1" + trace var x r "traceTag A1" + trace var x(0) r "traceTag 2" + trace var x r "traceTag A2" + trace var x(0) r "traceTag 3" + trace var x r "traceTag A3" + set x(0) + set info +} {A3 A2 A1 3 2 1} + +# Check effects of errors in trace procedures + +test trace-6.1 {error returns from traces} { + catch {unset x} + set x 123 + set info {} + trace var x r "traceTag 1" + trace var x r traceError + list [catch {set x} msg] $msg $info +} {1 {can't read "x": trace returned error} {}} +test trace-6.2 {error returns from traces} { + catch {unset x} + set x 123 + set info {} + trace var x w "traceTag 1" + trace var x w traceError + list [catch {set x 44} msg] $msg $info +} {1 {can't set "x": trace returned error} {}} +test trace-6.3 {error returns from traces} { + catch {unset x} + set x 123 + set info {} + trace var x u "traceTag 1" + trace var x u traceError + list [catch {unset x} msg] $msg $info +} {0 {} 1} +test trace-6.4 {error returns from traces} { + catch {unset x} + set x(0) 123 + set info {} + trace var x(0) r "traceTag 1" + trace var x r "traceTag 2" + trace var x r traceError + trace var x r "traceTag 3" + list [catch {set x(0)} msg] $msg $info +} {1 {can't read "x(0)": trace returned error} 3} +test trace-6.5 {error returns from traces} { + catch {unset x} + set x 123 + trace var x u traceError + list [catch {unset x} msg] $msg +} {0 {}} +test trace-6.6 {error returns from traces} { + # This test just makes sure that the memory for the error message + # gets deallocated correctly when the trace is invoked again or + # when the trace is deleted. + catch {unset x} + set x 123 + trace var x r traceError + catch {set x} + catch {set x} + trace vdelete x r traceError +} {} + +# Check to see that variables are expunged before trace +# procedures are invoked, so trace procedure can even manipulate +# a new copy of the variables. + +test trace-7.1 {be sure variable is unset before trace is called} { + catch {unset x} + set x 33 + set info {} + trace var x u {traceCheck {uplevel set x}} + unset x + set info +} {1 {can't read "x": no such variable}} +test trace-7.2 {be sure variable is unset before trace is called} { + catch {unset x} + set x 33 + set info {} + trace var x u {traceCheck {uplevel set x 22}} + unset x + concat $info [list [catch {set x} msg] $msg] +} {0 22 0 22} +test trace-7.3 {be sure traces are cleared before unset trace called} { + catch {unset x} + set x 33 + set info {} + trace var x u {traceCheck {uplevel trace vinfo x}} + unset x + set info +} {0 {}} +test trace-7.4 {set new trace during unset trace} { + catch {unset x} + set x 33 + set info {} + trace var x u {traceCheck {global x; trace var x u traceProc}} + unset x + concat $info [trace vinfo x] +} {0 {} {u traceProc}} + +test trace-8.1 {make sure array elements are unset before traces are called} { + catch {unset x} + set x(0) 33 + set info {} + trace var x(0) u {traceCheck {uplevel set x(0)}} + unset x(0) + set info +} {1 {can't read "x(0)": no such element in array}} +test trace-8.2 {make sure array elements are unset before traces are called} { + catch {unset x} + set x(0) 33 + set info {} + trace var x(0) u {traceCheck {uplevel set x(0) zzz}} + unset x(0) + concat $info [list [catch {set x(0)} msg] $msg] +} {0 zzz 0 zzz} +test trace-8.3 {array elements are unset before traces are called} { + catch {unset x} + set x(0) 33 + set info {} + trace var x(0) u {traceCheck {global x; trace vinfo x(0)}} + unset x(0) + set info +} {0 {}} +test trace-8.4 {set new array element trace during unset trace} { + catch {unset x} + set x(0) 33 + set info {} + trace var x(0) u {traceCheck {uplevel {trace variable x(0) r {}}}} + catch {unset x(0)} + concat $info [trace vinfo x(0)] +} {0 {} {r {}}} + +test trace-9.1 {make sure arrays are unset before traces are called} { + catch {unset x} + set x(0) 33 + set info {} + trace var x u {traceCheck {uplevel set x(0)}} + unset x + set info +} {1 {can't read "x(0)": no such variable}} +test trace-9.2 {make sure arrays are unset before traces are called} { + catch {unset x} + set x(y) 33 + set info {} + trace var x u {traceCheck {uplevel set x(y) 22}} + unset x + concat $info [list [catch {set x(y)} msg] $msg] +} {0 22 0 22} +test trace-9.3 {make sure arrays are unset before traces are called} { + catch {unset x} + set x(y) 33 + set info {} + trace var x u {traceCheck {uplevel array names x}} + unset x + set info +} {1 {"x" isn't an array}} +test trace-9.4 {make sure arrays are unset before traces are called} { + catch {unset x} + set x(y) 33 + set info {} + set cmd {traceCheck {uplevel {trace vinfo x}}} + trace var x u $cmd + unset x + set info +} {0 {}} +test trace-9.5 {set new array trace during unset trace} { + catch {unset x} + set x(y) 33 + set info {} + trace var x u {traceCheck {global x; trace var x r {}}} + unset x + concat $info [trace vinfo x] +} {0 {} {r {}}} +test trace-9.6 {create scalar during array unset trace} { + catch {unset x} + set x(y) 33 + set info {} + trace var x u {traceCheck {global x; set x 44}} + unset x + concat $info [list [catch {set x} msg] $msg] +} {0 44 0 44} + +# Check special conditions (e.g. errors) in Tcl_TraceVar2. + +test trace-10.1 {creating array when setting variable traces} { + catch {unset x} + set info {} + trace var x(0) w traceProc + list [catch {set x 22} msg] $msg +} {1 {can't set "x": variable is array}} +test trace-10.2 {creating array when setting variable traces} { + catch {unset x} + set info {} + trace var x(0) w traceProc + list [catch {set x(0)} msg] $msg +} {1 {can't read "x(0)": no such element in array}} +test trace-10.3 {creating array when setting variable traces} { + catch {unset x} + set info {} + trace var x(0) w traceProc + set x(0) 22 + set info +} {x 0 w} +test trace-10.4 {creating variable when setting variable traces} { + catch {unset x} + set info {} + trace var x w traceProc + list [catch {set x} msg] $msg +} {1 {can't read "x": no such variable}} +test trace-10.5 {creating variable when setting variable traces} { + catch {unset x} + set info {} + trace var x w traceProc + set x 22 + set info +} {x {} w} +test trace-10.6 {creating variable when setting variable traces} { + catch {unset x} + set info {} + trace var x w traceProc + set x(0) 22 + set info +} {x 0 w} +test trace-10.7 {create array element during read trace} { + catch {unset x} + set x(2) zzz + trace var x r {traceCrtElement xyzzy} + list [catch {set x(3)} msg] $msg +} {0 xyzzy} +test trace-10.8 {errors when setting variable traces} { + catch {unset x} + set x 44 + list [catch {trace var x(0) w traceProc} msg] $msg +} {1 {can't trace "x(0)": variable isn't array}} + +# Check deleting one trace from another. + +test trace-11.1 {delete one trace from another} { + proc delTraces {args} { + global x + trace vdel x r {traceTag 2} + trace vdel x r {traceTag 3} + trace vdel x r {traceTag 4} + } + catch {unset x} + set x 44 + set info {} + trace var x r {traceTag 1} + trace var x r {traceTag 2} + trace var x r {traceTag 3} + trace var x r {traceTag 4} + trace var x r delTraces + trace var x r {traceTag 5} + set x + set info +} {5 1} + +# Check operation and syntax of "trace" command. + +test trace-12.1 {trace command (overall)} { + list [catch {trace} msg] $msg +} {1 {too few args: should be "trace option [arg arg ...]"}} +test trace-12.2 {trace command (overall)} { + list [catch {trace gorp} msg] $msg +} {1 {bad option "gorp": should be variable, vdelete, or vinfo}} +test trace-12.3 {trace command ("variable" option)} { + list [catch {trace variable x y} msg] $msg +} {1 {wrong # args: should be "trace variable name ops command"}} +test trace-12.4 {trace command ("variable" option)} { + list [catch {trace var x y z z2} msg] $msg +} {1 {wrong # args: should be "trace variable name ops command"}} +test trace-12.5 {trace command ("variable" option)} { + list [catch {trace var x y z} msg] $msg +} {1 {bad operations "y": should be one or more of rwu}} +test trace-12.6 {trace command ("vdelete" option)} { + list [catch {trace vdelete x y} msg] $msg +} {1 {wrong # args: should be "trace vdelete name ops command"}} +test trace-12.7 {trace command ("vdelete" option)} { + list [catch {trace vdelete x y z foo} msg] $msg +} {1 {wrong # args: should be "trace vdelete name ops command"}} +test trace-12.8 {trace command ("vdelete" option)} { + list [catch {trace vdelete x y z} msg] $msg +} {1 {bad operations "y": should be one or more of rwu}} +test trace-12.9 {trace command ("vdelete" option)} { + catch {unset x} + set info {} + trace var x w traceProc + trace vdelete x w traceProc +} {} +test trace-12.10 {trace command ("vdelete" option)} { + catch {unset x} + set info {} + trace var x w traceProc + trace vdelete x w traceProc + set x 12345 + set info +} {} +test trace-12.11 {trace command ("vdelete" option)} { + catch {unset x} + set info {} + trace var x w {traceTag 1} + trace var x w traceProc + trace var x w {traceTag 2} + set x yy + trace vdelete x w traceProc + set x 12345 + trace vdelete x w {traceTag 1} + set x foo + trace vdelete x w {traceTag 2} + set x gorp + set info +} {2 x {} w 1 2 1 2} +test trace-12.12 {trace command ("vdelete" option)} { + catch {unset x} + set info {} + trace var x w {traceTag 1} + trace vdelete x w non_existent + set x 12345 + set info +} {1} +test trace-12.13 {trace command ("vinfo" option)} { + list [catch {trace vinfo} msg] $msg] +} {1 {wrong # args: should be "trace vinfo name"]}} +test trace-12.14 {trace command ("vinfo" option)} { + list [catch {trace vinfo x y} msg] $msg] +} {1 {wrong # args: should be "trace vinfo name"]}} +test trace-12.15 {trace command ("vinfo" option)} { + catch {unset x} + trace var x w {traceTag 1} + trace var x w traceProc + trace var x w {traceTag 2} + trace vinfo x +} {{w {traceTag 2}} {w traceProc} {w {traceTag 1}}} +test trace-12.16 {trace command ("vinfo" option)} { + catch {unset x} + trace vinfo x +} {} +test trace-12.17 {trace command ("vinfo" option)} { + catch {unset x} + trace vinfo x(0) +} {} +test trace-12.18 {trace command ("vinfo" option)} { + catch {unset x} + set x 44 + trace vinfo x(0) +} {} +test trace-12.19 {trace command ("vinfo" option)} { + catch {unset x} + set x 44 + trace var x w {traceTag 1} + proc check {} {global x; trace vinfo x} + check +} {{w {traceTag 1}}} + +# Check fancy trace commands (long ones, weird arguments, etc.) + +test trace-13.1 {long trace command} { + catch {unset x} + set info {} + trace var x w {traceTag {This is a very very long argument. It's \ + designed to test out the facilities of TraceVarProc for dealing \ + with such long arguments by malloc-ing space. One possibility \ + is that space doesn't get freed properly. If this happens, then \ + invoking this test over and over again will eventually leak memory.}} + set x 44 + set info +} {This is a very very long argument. It's \ + designed to test out the facilities of TraceVarProc for dealing \ + with such long arguments by malloc-ing space. One possibility \ + is that space doesn't get freed properly. If this happens, then \ + invoking this test over and over again will eventually leak memory.} +test trace-13.2 {long trace command result to ignore} { + proc longResult {args} {return "quite a bit of text, designed to + generate a core leak if this command file is invoked over and over again + and memory isn't being recycled correctly"} + catch {unset x} + trace var x w longResult + set x 44 + set x 5 + set x abcde +} abcde +test trace-13.3 {special list-handling in trace commands} { + catch {unset "x y z"} + set "x y z(a\n\{)" 44 + set info {} + trace var "x y z(a\n\{)" w traceProc + set "x y z(a\n\{)" 33 + set info +} "{x y z} a\\n\\{ w" + +# Check for proper handling of unsets during traces. + +proc traceUnset {unsetName args} { + global info + upvar $unsetName x + lappend info [catch {unset x} msg] $msg [catch {set x} msg] $msg +} +proc traceReset {unsetName resetName args} { + global info + upvar $unsetName x $resetName y + lappend info [catch {unset x} msg] $msg [catch {set y xyzzy} msg] $msg +} +proc traceReset2 {unsetName resetName args} { + global info + lappend info [catch {uplevel unset $unsetName} msg] $msg \ + [catch {uplevel set $resetName xyzzy} msg] $msg +} +proc traceAppend {string name1 name2 op} { + global info + lappend info $string +} + +test trace-14.1 {unsets during read traces} { + catch {unset y} + set y 1234 + set info {} + trace var y r {traceUnset y} + trace var y u {traceAppend unset} + lappend info [catch {set y} msg] $msg +} {unset 0 {} 1 {can't read "x": no such variable} 1 {can't read "y": no such variable}} +test trace-14.2 {unsets during read traces} { + catch {unset y} + set y(0) 1234 + set info {} + trace var y(0) r {traceUnset y(0)} + lappend info [catch {set y(0)} msg] $msg +} {0 {} 1 {can't read "x": no such variable} 1 {can't read "y(0)": no such element in array}} +test trace-14.3 {unsets during read traces} { + catch {unset y} + set y(0) 1234 + set info {} + trace var y(0) r {traceUnset y} + lappend info [catch {set y(0)} msg] $msg +} {0 {} 1 {can't read "x": no such variable} 1 {can't read "y(0)": no such variable}} +test trace-14.4 {unsets during read traces} { + catch {unset y} + set y 1234 + set info {} + trace var y r {traceReset y y} + lappend info [catch {set y} msg] $msg +} {0 {} 0 xyzzy 0 xyzzy} +test trace-14.5 {unsets during read traces} { + catch {unset y} + set y(0) 1234 + set info {} + trace var y(0) r {traceReset y(0) y(0)} + lappend info [catch {set y(0)} msg] $msg +} {0 {} 0 xyzzy 0 xyzzy} +test trace-14.6 {unsets during read traces} { + catch {unset y} + set y(0) 1234 + set info {} + trace var y(0) r {traceReset y y(0)} + lappend info [catch {set y(0)} msg] $msg [catch {set y(0)} msg] $msg +} {0 {} 1 {can't set "y": upvar refers to element in deleted array} 1 {can't read "y(0)": no such variable} 1 {can't read "y(0)": no such variable}} +test trace-14.7 {unsets during read traces} { + catch {unset y} + set y(0) 1234 + set info {} + trace var y(0) r {traceReset2 y y(0)} + lappend info [catch {set y(0)} msg] $msg [catch {set y(0)} msg] $msg +} {0 {} 0 xyzzy 1 {can't read "y(0)": no such element in array} 0 xyzzy} +test trace-14.8 {unsets during write traces} { + catch {unset y} + set y 1234 + set info {} + trace var y w {traceUnset y} + trace var y u {traceAppend unset} + lappend info [catch {set y xxx} msg] $msg +} {unset 0 {} 1 {can't read "x": no such variable} 0 {}} +test trace-14.9 {unsets during write traces} { + catch {unset y} + set y(0) 1234 + set info {} + trace var y(0) w {traceUnset y(0)} + lappend info [catch {set y(0) xxx} msg] $msg +} {0 {} 1 {can't read "x": no such variable} 0 {}} +test trace-14.10 {unsets during write traces} { + catch {unset y} + set y(0) 1234 + set info {} + trace var y(0) w {traceUnset y} + lappend info [catch {set y(0) xxx} msg] $msg +} {0 {} 1 {can't read "x": no such variable} 0 {}} +test trace-14.11 {unsets during write traces} { + catch {unset y} + set y 1234 + set info {} + trace var y w {traceReset y y} + lappend info [catch {set y xxx} msg] $msg +} {0 {} 0 xyzzy 0 xyzzy} +test trace-14.12 {unsets during write traces} { + catch {unset y} + set y(0) 1234 + set info {} + trace var y(0) w {traceReset y(0) y(0)} + lappend info [catch {set y(0) xxx} msg] $msg +} {0 {} 0 xyzzy 0 xyzzy} +test trace-14.13 {unsets during write traces} { + catch {unset y} + set y(0) 1234 + set info {} + trace var y(0) w {traceReset y y(0)} + lappend info [catch {set y(0) xxx} msg] $msg [catch {set y(0)} msg] $msg +} {0 {} 1 {can't set "y": upvar refers to element in deleted array} 0 {} 1 {can't read "y(0)": no such variable}} +test trace-14.14 {unsets during write traces} { + catch {unset y} + set y(0) 1234 + set info {} + trace var y(0) w {traceReset2 y y(0)} + lappend info [catch {set y(0) xxx} msg] $msg [catch {set y(0)} msg] $msg +} {0 {} 0 xyzzy 0 {} 0 xyzzy} +test trace-14.15 {unsets during unset traces} { + catch {unset y} + set y 1234 + set info {} + trace var y u {traceUnset y} + lappend info [catch {unset y} msg] $msg [catch {set y} msg] $msg +} {1 {can't unset "x": no such variable} 1 {can't read "x": no such variable} 0 {} 1 {can't read "y": no such variable}} +test trace-14.16 {unsets during unset traces} { + catch {unset y} + set y(0) 1234 + set info {} + trace var y(0) u {traceUnset y(0)} + lappend info [catch {unset y(0)} msg] $msg [catch {set y(0)} msg] $msg +} {1 {can't unset "x": no such variable} 1 {can't read "x": no such variable} 0 {} 1 {can't read "y(0)": no such element in array}} +test trace-14.17 {unsets during unset traces} { + catch {unset y} + set y(0) 1234 + set info {} + trace var y(0) u {traceUnset y} + lappend info [catch {unset y(0)} msg] $msg [catch {set y(0)} msg] $msg +} {0 {} 1 {can't read "x": no such variable} 0 {} 1 {can't read "y(0)": no such variable}} +test trace-14.18 {unsets during unset traces} { + catch {unset y} + set y 1234 + set info {} + trace var y u {traceReset2 y y} + lappend info [catch {unset y} msg] $msg [catch {set y} msg] $msg +} {1 {can't unset "y": no such variable} 0 xyzzy 0 {} 0 xyzzy} +test trace-14.19 {unsets during unset traces} { + catch {unset y} + set y(0) 1234 + set info {} + trace var y(0) u {traceReset2 y(0) y(0)} + lappend info [catch {unset y(0)} msg] $msg [catch {set y(0)} msg] $msg +} {1 {can't unset "y(0)": no such element in array} 0 xyzzy 0 {} 0 xyzzy} +test trace-14.20 {unsets during unset traces} { + catch {unset y} + set y(0) 1234 + set info {} + trace var y(0) u {traceReset2 y y(0)} + lappend info [catch {unset y(0)} msg] $msg [catch {set y(0)} msg] $msg +} {0 {} 0 xyzzy 0 {} 0 xyzzy} +test trace-14.21 {unsets cancelling traces} { + catch {unset y} + set y 1234 + set info {} + trace var y r {traceAppend first} + trace var y r {traceUnset y} + trace var y r {traceAppend third} + trace var y u {traceAppend unset} + lappend info [catch {set y} msg] $msg +} {third unset 0 {} 1 {can't read "x": no such variable} 1 {can't read "y": no such variable}} +test trace-14.22 {unsets cancelling traces} { + catch {unset y} + set y(0) 1234 + set info {} + trace var y(0) r {traceAppend first} + trace var y(0) r {traceUnset y} + trace var y(0) r {traceAppend third} + trace var y(0) u {traceAppend unset} + lappend info [catch {set y(0)} msg] $msg +} {third unset 0 {} 1 {can't read "x": no such variable} 1 {can't read "y(0)": no such variable}} + +# Check various non-interference between traces and other things. + +test trace-15.1 {trace doesn't prevent unset errors} { + catch {unset x} + set info {} + trace var x u {traceProc} + list [catch {unset x} msg] $msg $info +} {1 {can't unset "x": no such variable} {x {} u}} +test trace-15.2 {traced variables must survive procedure exits} { + catch {unset x} + proc p1 {} {global x; trace var x w traceProc} + p1 + trace vinfo x +} {{w traceProc}} +test trace-15.3 {traced variables must survive procedure exits} { + catch {unset x} + set info {} + proc p1 {} {global x; trace var x w traceProc} + p1 + set x 44 + set info +} {x {} w} + +# Be sure that procedure frames are released before unset traces +# are invoked. + +test trace-16.1 {unset traces on procedure returns} { + proc p1 {x y} {set a 44; p2 14} + proc p2 {z} {trace var z u {traceCheck {lsort [uplevel {info vars}]}}} + set info {} + p1 foo bar + set info +} {0 {a x y}} + +# Delete arrays when done, so they can be re-used as scalars +# elsewhere. + +catch {unset x} +catch {unset y} +concat {} diff --git a/vendor/x11iraf/obm/Tcl/tests/unknown.test b/vendor/x11iraf/obm/Tcl/tests/unknown.test new file mode 100644 index 00000000..e80258af --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/tests/unknown.test @@ -0,0 +1,73 @@ +# Commands covered: unknown +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1991-1993 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. +# +# $Header: /user6/ouster/tcl/tests/RCS/unknown.test,v 1.7 93/10/11 09:06:00 ouster Exp $ (Berkeley) + +if {[string compare test [info procs test]] == 1} then {source defs} + +catch {rename unknown {}} + +test unknown-1.1 {non-existent "unknown" command} { + list [catch {_non-existent_ foo bar} msg] $msg +} {1 {invalid command name: "_non-existent_"}} + +proc unknown {args} { + global x + set x $args +} + +test unknown-2.1 {calling "unknown" command} { + foobar x y z + set x +} {foobar x y z} +test unknown-2.2 {calling "unknown" command with lots of args} { + foobar 1 2 3 4 5 6 7 + set x +} {foobar 1 2 3 4 5 6 7} +test unknown-2.3 {calling "unknown" command with lots of args} { + foobar 1 2 3 4 5 6 7 8 + set x +} {foobar 1 2 3 4 5 6 7 8} +test unknown-2.4 {calling "unknown" command with lots of args} { + foobar 1 2 3 4 5 6 7 8 9 + set x +} {foobar 1 2 3 4 5 6 7 8 9} + +test unknown-3.1 {argument quoting in calls to "unknown"} { + foobar \{ \} a\{b \; "\\" \$a a\[b \] + set x +} "foobar \\{ \\} a\\{b {;} \\\\ {\$a} {a\[b} \\]" + +proc unknown args { + error "unknown failed" +} + +test unknown-4.1 {errors in "unknown" procedure} { + list [catch {non-existent a b} msg] $msg $errorCode +} {1 {unknown failed} NONE} + +catch {rename unknown {}} +return {} diff --git a/vendor/x11iraf/obm/Tcl/tests/uplevel.test b/vendor/x11iraf/obm/Tcl/tests/uplevel.test new file mode 100644 index 00000000..675cb335 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/tests/uplevel.test @@ -0,0 +1,123 @@ +# Commands covered: uplevel +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1991-1993 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. +# +# $Header: /user6/ouster/tcl/tests/RCS/uplevel.test,v 1.11 93/07/17 14:38:22 ouster Exp $ (Berkeley) + +if {[string compare test [info procs test]] == 1} then {source defs} + +proc a {x y} { + newset z [expr $x+$y] + return $z +} +proc newset {name value} { + uplevel set $name $value + uplevel 1 {uplevel 1 {set xyz 22}} +} + +test uplevel-1.1 {simple operation} { + set xyz 0 + a 22 33 +} 55 +test uplevel-1.2 {command is another uplevel command} { + set xyz 0 + a 22 33 + set xyz +} 22 + +proc a1 {} { + b1 + global a a1 + set a $x + set a1 $y +} +proc b1 {} { + c1 + global b b1 + set b $x + set b1 $y +} +proc c1 {} { + uplevel 1 set x 111 + uplevel #2 set y 222 + uplevel 2 set x 333 + uplevel #1 set y 444 + uplevel 3 set x 555 + uplevel #0 set y 666 +} +a1 +test uplevel-2.1 {relative and absolute uplevel} {set a} 333 +test uplevel-2.2 {relative and absolute uplevel} {set a1} 444 +test uplevel-2.3 {relative and absolute uplevel} {set b} 111 +test uplevel-2.4 {relative and absolute uplevel} {set b1} 222 +test uplevel-2.5 {relative and absolute uplevel} {set x} 555 +test uplevel-2.6 {relative and absolute uplevel} {set y} 666 + +test uplevel-3.1 {uplevel to same level} { + set x 33 + uplevel #0 set x 44 + set x +} 44 +test uplevel-3.2 {uplevel to same level} { + set x 33 + uplevel 0 set x +} 33 +test uplevel-3.3 {uplevel to same level} { + set y xxx + proc a1 {} {set y 55; uplevel 0 set y 66; return $y} + a1 +} 66 +test uplevel-3.4 {uplevel to same level} { + set y zzz + proc a1 {} {set y 55; uplevel #1 set y} + a1 +} 55 + +test uplevel-4.1 {error: non-existent level} { + list [catch c1 msg] $msg +} {1 {bad level "#2"}} +test uplevel-4.2 {error: non-existent level} { + proc c2 {} {uplevel 3 {set a b}} + list [catch c2 msg] $msg +} {1 {bad level "3"}} +test uplevel-4.3 {error: not enough args} { + list [catch uplevel msg] $msg +} {1 {wrong # args: should be "uplevel ?level? command ?arg ...?"}} +test uplevel-4.4 {error: not enough args} { + proc upBug {} {uplevel 1} + list [catch upBug msg] $msg +} {1 {wrong # args: should be "uplevel ?level? command ?arg ...?"}} + +proc a2 {} { + uplevel a3 +} +proc a3 {} { + global x y + set x [info level] + set y [info level 1] +} +a2 +test uplevel-5.1 {info level} {set x} 1 +test uplevel-5.2 {info level} {set y} a3 diff --git a/vendor/x11iraf/obm/Tcl/tests/upvar.test b/vendor/x11iraf/obm/Tcl/tests/upvar.test new file mode 100644 index 00000000..bfef720c --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/tests/upvar.test @@ -0,0 +1,303 @@ +# Commands covered: upvar +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1991-1993 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. +# +# $Header: /user6/ouster/tcl/tests/RCS/upvar.test,v 1.4 93/07/17 14:38:10 ouster Exp $ (Berkeley) + +if {[string compare test [info procs test]] == 1} then {source defs} + +test upvar-1.1 {reading variables with upvar} { + proc p1 {a b} {set c 22; set d 33; p2} + proc p2 {} {upvar a x1 b x2 c x3 d x4; set a abc; list $x1 $x2 $x3 $x4 $a} + p1 foo bar +} {foo bar 22 33 abc} +test upvar-1.2 {reading variables with upvar} { + proc p1 {a b} {set c 22; set d 33; p2} + proc p2 {} {p3} + proc p3 {} {upvar 2 a x1 b x2 c x3 d x4; set a abc; list $x1 $x2 $x3 $x4 $a} + p1 foo bar +} {foo bar 22 33 abc} +test upvar-1.3 {reading variables with upvar} { + proc p1 {a b} {set c 22; set d 33; p2} + proc p2 {} {p3} + proc p3 {} { + upvar #1 a x1 b x2 c x3 d x4 + set a abc + list $x1 $x2 $x3 $x4 $a + } + p1 foo bar +} {foo bar 22 33 abc} +test upvar-1.4 {reading variables with upvar} { + set x1 44 + set x2 55 + proc p1 {} {p2} + proc p2 {} { + upvar 2 x1 x1 x2 a + upvar #0 x1 b + set c $b + incr b 3 + list $x1 $a $b + } + p1 +} {47 55 47} +test upvar-1.4 {reading array elements with upvar} { + proc p1 {} {set a(0) zeroth; set a(1) first; p2} + proc p2 {} {upvar a(0) x; set x} + p1 +} {zeroth} + +test upvar-2.1 {writing variables with upvar} { + proc p1 {a b} {set c 22; set d 33; p2; list $a $b $c $d} + proc p2 {} { + upvar a x1 b x2 c x3 d x4 + set x1 14 + set x4 88 + } + p1 foo bar +} {14 bar 22 88} +test upvar-2.2 {writing variables with upvar} { + set x1 44 + set x2 55 + proc p1 {x1 x2} { + upvar #0 x1 a + upvar x2 b + set a $x1 + set b $x2 + } + p1 newbits morebits + list $x1 $x2 +} {newbits morebits} +test upvar-2.3 {writing variables with upvar} { + catch {unset x1} + catch {unset x2} + proc p1 {x1 x2} { + upvar #0 x1 a + upvar x2 b + set a $x1 + set b $x2 + } + p1 newbits morebits + list [catch {set x1} msg] $msg [catch {set x2} msg] $msg +} {0 newbits 0 morebits} +test upvar-2.4 {writing array elements with upvar} { + proc p1 {} {set a(0) zeroth; set a(1) first; list [p2] $a(0)} + proc p2 {} {upvar a(0) x; set x xyzzy} + p1 +} {xyzzy xyzzy} + +test upvar-3.1 {unsetting variables with upvar} { + proc p1 {a b} {set c 22; set d 33; p2; lsort [info vars]} + proc p2 {} { + upvar 1 a x1 d x2 + unset x1 x2 + } + p1 foo bar +} {b c} +test upvar-3.2 {unsetting variables with upvar} { + proc p1 {a b} {set c 22; set d 33; p2; lsort [info vars]} + proc p2 {} { + upvar 1 a x1 d x2 + unset x1 x2 + set x2 28 + } + p1 foo bar +} {b c d} +test upvar-3.3 {unsetting variables with upvar} { + set x1 44 + set x2 55 + proc p1 {} {p2} + proc p2 {} { + upvar 2 x1 a + upvar #0 x2 b + unset a b + } + p1 + list [info exists x1] [info exists x2] +} {0 0} +test upvar-3.4 {unsetting variables with upvar} { + set x1 44 + set x2 55 + proc p1 {} { + upvar x1 a x2 b + unset a b + set b 118 + } + p1 + list [info exists x1] [catch {set x2} msg] $msg +} {0 0 118} +test upvar-3.5 {unsetting array elements with upvar} { + proc p1 {} { + set a(0) zeroth + set a(1) first + set a(2) second + p2 + array names a + } + proc p2 {} {upvar a(0) x; unset x} + p1 +} {1 2} +test upvar-3.6 {unsetting then resetting array elements with upvar} { + proc p1 {} { + set a(0) zeroth + set a(1) first + set a(2) second + p2 + list [array names a] [catch {set a(0)} msg] $msg + } + proc p2 {} {upvar a(0) x; unset x; set x 12345} + p1 +} {{0 1 2} 0 12345} + +test upvar-4.1 {nested upvars} { + set x1 88 + proc p1 {a b} {set c 22; set d 33; p2} + proc p2 {} {global x1; upvar c x2; p3} + proc p3 {} { + upvar x1 a x2 b + list $a $b + } + p1 14 15 +} {88 22} +test upvar-4.2 {nested upvars} { + set x1 88 + proc p1 {a b} {set c 22; set d 33; p2; list $a $b $c $d} + proc p2 {} {global x1; upvar c x2; p3} + proc p3 {} { + upvar x1 a x2 b + set a foo + set b bar + } + list [p1 14 15] $x1 +} {{14 15 bar 33} foo} + +proc tproc {args} {global x; set x [list $args [uplevel info vars]]} +test upvar-5.1 {traces involving upvars} { + proc p1 {a b} {set c 22; set d 33; trace var c rw tproc; p2} + proc p2 {} {upvar c x1; set x1 22} + set x --- + p1 foo bar + set x +} {{x1 {} w} x1} +test upvar-5.2 {traces involving upvars} { + proc p1 {a b} {set c 22; set d 33; trace var c rw tproc; p2} + proc p2 {} {upvar c x1; set x1} + set x --- + p1 foo bar + set x +} {{x1 {} r} x1} +test upvar-5.3 {traces involving upvars} { + proc p1 {a b} {set c 22; set d 33; trace var c rwu tproc; p2} + proc p2 {} {upvar c x1; unset x1} + set x --- + p1 foo bar + set x +} {{x1 {} u} x1} + +test upvar-6.1 {retargeting an upvar} { + proc p1 {} { + set a(0) zeroth + set a(1) first + set a(2) second + p2 + } + proc p2 {} { + upvar a x + set result {} + foreach i [array names x] { + upvar a($i) x + lappend result $x + } + lsort $result + } + p1 +} {first second zeroth} +test upvar-6.2 {retargeting an upvar} { + set x 44 + set y abcde + proc p1 {} { + global x + set result $x + upvar y x + lappend result $x + } + p1 +} {44 abcde} +test upvar-6.3 {retargeting an upvar} { + set x 44 + set y abcde + proc p1 {} { + upvar y x + lappend result $x + global x + lappend result $x + } + p1 +} {abcde 44} + +test upvar-7.1 {upvar to same level} { + set x 44 + set y 55 + catch {unset uv} + upvar #0 x uv + set uv abc + upvar 0 y uv + set uv xyzzy + list $x $y +} {abc xyzzy} +test upvar-7.2 {upvar to same level} { + set x 1234 + set y 4567 + proc p1 {x y} { + upvar 0 x uv + set uv $y + return "$x $y" + } + p1 44 89 +} {89 89} +test upvar-7.3 {upvar to same level} { + set x 1234 + set y 4567 + proc p1 {x y} { + upvar #1 x uv + set uv $y + return "$x $y" + } + p1 xyz abc +} {abc abc} + +test upvar-8.1 {errors in upvar command} { + list [catch upvar msg] $msg +} {1 {wrong # args: should be "upvar ?level? otherVar localVar ?otherVar localVar ...?"}} +test upvar-8.2 {errors in upvar command} { + list [catch {upvar 1} msg] $msg +} {1 {wrong # args: should be "upvar ?level? otherVar localVar ?otherVar localVar ...?"}} +test upvar-8.3 {errors in upvar command} { + proc p1 {} {upvar a b c} + list [catch p1 msg] $msg +} {1 {wrong # args: should be "upvar ?level? otherVar localVar ?otherVar localVar ...?"}} +test upvar-8.4 {errors in upvar command} { + proc p1 {} {set a 33; upvar b a} + list [catch p1 msg] $msg +} {1 {variable "a" already exists}} diff --git a/vendor/x11iraf/obm/Tcl/tests/while.test b/vendor/x11iraf/obm/Tcl/tests/while.test new file mode 100644 index 00000000..48a08e19 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/tests/while.test @@ -0,0 +1,113 @@ +# Commands covered: while +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1991-1993 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. +# +# $Header: /user6/ouster/tcl/tests/RCS/while.test,v 1.7 93/04/21 11:18:58 ouster Exp $ (Berkeley) + +if {[string compare test [info procs test]] == 1} then {source defs} + +test while-1.1 {basic while loops} { + set count 0 + while {$count < 10} {set count [expr $count+1]} + set count +} 10 +test while-1.2 {basic while loops} { + set value xxx + while {2 > 3} {set value yyy} + set value +} xxx +test while-1.3 {basic while loops} { + set value 1 + while {"true"} { + incr value; + if {$value > 5} { + break; + } + } + set value +} 6 + +test while-2.1 {continue in while loop} { + set list {1 2 3 4 5} + set index 0 + set result {} + while {$index < 5} { + if {$index == 2} {set index [expr $index+1]; continue} + set result [concat $result [lindex $list $index]] + set index [expr $index+1] + } + set result +} {1 2 4 5} + +test while-3.1 {break in while loop} { + set list {1 2 3 4 5} + set index 0 + set result {} + while {$index < 5} { + if {$index == 3} break + set result [concat $result [lindex $list $index]] + set index [expr $index+1] + } + set result +} {1 2 3} + +test while-4.1 {errors in while loops} { + set err [catch {while} msg] + list $err $msg +} {1 {wrong # args: should be "while test command"}} +test while-4.2 {errors in while loops} { + set err [catch {while 1} msg] + list $err $msg +} {1 {wrong # args: should be "while test command"}} +test while-4.3 {errors in while loops} { + set err [catch {while 1 2 3} msg] + list $err $msg +} {1 {wrong # args: should be "while test command"}} +test while-4.4 {errors in while loops} { + set err [catch {while {"a"+"b"} {error "loop aborted"}} msg] + list $err $msg +} {1 {can't use non-numeric string as operand of "+"}} +test while-4.5 {errors in while loops} { + set x 1 + set err [catch {while {$x} {set x foo}} msg] + list $err $msg +} {1 {expected boolean value but got "foo"}} +test while-4.6 {errors in while loops} { + set err [catch {while {1} {error "loop aborted"}} msg] + list $err $msg $errorInfo +} {1 {loop aborted} {loop aborted + while executing +"error "loop aborted"" + ("while" body line 1) + invoked from within +"while {1} {error "loop aborted"}"}} + +test while-5.1 {while return result} { + while {0} {set a 400} +} {} +test while-5.2 {while return result} { + set x 1 + while {$x} {set x 0} +} {} |